├── .gitignore ├── README.md ├── docs ├── bibliography.bib ├── codeSamples.tex ├── diary.tex ├── glossary.tex ├── images │ ├── callgraph.png │ ├── comment.jpg │ ├── help.jpg │ ├── logo.jpg │ ├── modulo.jpg │ ├── odd.jpg │ ├── parsetext.jpg │ ├── pipe.jpg │ ├── randomBanner.jpg │ ├── tree.jpg │ ├── typeError.jpg │ └── vim.jpg ├── initialreport.tex ├── libs.tex ├── markdown.tex ├── mmlcode.tex ├── progressreport.latex ├── repl.tex ├── replCode.tex ├── report.tex ├── req.tex ├── syntax.tex ├── sysf.tex ├── texBib └── user.tex ├── installMicroML ├── microML.cabal ├── src ├── Compiler │ ├── CallGraph.hs │ ├── CodeGen.hs │ ├── Failure.hs │ ├── MicroBitHeader.hs │ └── PrettyCPP.hs ├── Jit │ ├── Codegen.hs │ └── Emit.hs ├── Libs │ ├── church.mml │ ├── combinators.mml │ ├── glossary.mml │ ├── maths.mml │ ├── standard.mml │ └── string.mml ├── Main.hs ├── MicroML │ ├── Config.hs │ ├── Lexer.hs │ ├── ListPrimitives.hs │ ├── MathsPrimitives.hs │ ├── Parser.hs │ ├── Syntax.hs │ └── Typing │ │ ├── Env.hs │ │ ├── Infer.hs │ │ ├── Substitutable.hs │ │ ├── Type.hs │ │ └── TypeError.hs └── Repl │ ├── Eval.hs │ ├── Help.hs │ ├── HelpEnv.hs │ ├── ParseTree.hs │ ├── Pretty.hs │ └── Repl.hs ├── stack.yaml ├── test ├── CallGraphSpec.hs ├── EvalSpec.hs ├── ListPrimitivesSpec.hs ├── MathsPrimitives.hs ├── TestMain.hs └── compiler │ ├── addition.mml │ ├── badType.mml │ ├── badTypeSimple.mml │ ├── duplicateFail.mml │ ├── empty.mml │ ├── funcCall.mml │ ├── helloWorld.mml │ ├── ifStatement.mml │ ├── letDecl.mml │ ├── linkedUnreachable.mml │ ├── multiFunc.mml │ ├── multiLet.mml │ ├── receiver.mml │ └── unreachable.mml └── utils ├── compilerTests.sh ├── microML.vim ├── autoload │ ├── funcs.vim │ └── microMLcomplete.vim ├── ftdetect │ └── microML.vim ├── ftplugin │ └── microML.vim └── syntax │ └── microML.vim └── microMLrc /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | dist/ 3 | .cabal-sandbox/ 4 | cabal.sandbox.config 5 | .hdevtools.sock 6 | .stack-work/ 7 | .history 8 | microML 9 | .o 10 | .hi 11 | *.cpp 12 | *.aux 13 | *.out 14 | *.toc 15 | *.log 16 | *.pdf 17 | *.fls 18 | *.fdb_latexmk 19 | *.bbl 20 | *.blg 21 | *.glo 22 | *.gls 23 | *.glsdefs 24 | *.ist 25 | *.lof 26 | *.lot 27 | *.ilg 28 | _minted-report 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # microML 2 | 3 | **UPDATE** 4 | 5 | At the moment I simply have no time to work on this, or to fix the many, many, many problems and 6 | dreadful code scattered throughout the project. This was my first attempt at writing anything real in 7 | Haskell, and I'm sad to say it's pretty obvious. Please regard this as an interesting curiosity 8 | only! Do not attempt to use!!! 9 | 10 | 11 | **for UCL MSc Computer Science.** 12 | 13 | 14 | microML is a simple functional programming language designed for the *BBC micro:bit* microcomputer. It is 15 | essentially a lisp, with a bit of ml style sugar on the syntax. 16 | 17 | This is still under active development so please don't try to use it yet! However, if you really really want, 18 | there is a repl you can use for a quick feel of the language. 19 | 20 | *Work in progress* 21 | 22 | Here's a quick overview of the syntax: 23 | 24 | Declarations (simple and recursive) are introduced with a _let_ 25 | 26 | ```ml 27 | microML ⊦ let x = 5 28 | microML ⊦ 5 : Number 29 | microML ⊦ let incBy1 x = x + 1 30 | microML ⊦ :type inc 31 | microML ⊦ inc : Number -> Number 32 | ``` 33 | 34 | or 35 | 36 | ```ml 37 | microML ⊦ let incBy1 = \x -> x + 1 38 | microML ⊦ incBy1 2 39 | microML ⊦ 3 : Number 40 | ``` 41 | 42 | More complex things can be entered at the repl as well (at the moment everything must be on one line) 43 | 44 | ```ml 45 | microML ⊦ let compose x y = \z -> x (y z) 46 | microML ⊦ compose inc inc 2 47 | microML ⊦ 4 : Number 48 | 49 | microML ⊦ let fact n = if n == 0 then 1 else n * (fact (n-1)) 50 | microML ⊦ fact 5 51 | microML ⊦ 120 : Number 52 | ``` 53 | 54 | TODO 55 | ==== 56 | 57 | My first attempt at writing anything more than an individual function in Haskell... and it shows it. 58 | Lots of good stuff here, but also a lot that needs to be rewritten when there's the time now that I 59 | understand a bit more about how to do things. 60 | 61 | + Working on type inference at the moment... 62 | + Compiler to C++ (for the micro:bit) 63 | -------------------------------------------------------------------------------- /docs/bibliography.bib: -------------------------------------------------------------------------------- 1 | @book{Harper:2012:PFP:2431407, 2 | author = {Harper, Professor Robert}, 3 | title = {Practical Foundations for Programming Languages}, 4 | year = {2012}, 5 | isbn = {1107029570, 9781107029576}, 6 | publisher = {Cambridge University Press}, 7 | address = {New York, NY, USA}, 8 | } 9 | 10 | @book{Appel:1997:MCI:248430, 11 | author = {Appel, Andrew W.}, 12 | title = {Modern Compiler Implementation in ML: Basic Techniques}, 13 | year = {1997}, 14 | isbn = {0-521-58775-1}, 15 | publisher = {Cambridge University Press}, 16 | address = {New York, NY, USA}, 17 | } 18 | 19 | @book{torc, 20 | author={Torczon, Linda and Keith Cooper}, 21 | title={Engineering A Compiler}, 22 | publisher={Morgan Kaufmann}, 23 | year=2007 24 | } 25 | 26 | @book{spj1, 27 | title = "Implementing functional languages", 28 | author = "Peyton Jones, Simon L. and Lester, David R.", 29 | series = "Prentice Hall international series in computer science", 30 | publisher = "Prentice Hall, Impr.", 31 | address = "New York", 32 | url = "http://opac.inria.fr/record=b1089179", 33 | isbn = "0-13-721952-0", 34 | year = 1992 35 | } 36 | 37 | @book{spj2, 38 | author={Peyton Jones, Simon L}, 39 | title={The Implementation of Functional Programming Languages}, 40 | publisher={Prentice Hall}, 41 | address={Hemel Hempstead}, 42 | year=1987 43 | } 44 | 45 | @book{rwh, 46 | author = {O'Sullivan, Bryan and Goerzen, John and Stewart, Don}, 47 | title = {Real World Haskell}, 48 | year = {2008}, 49 | isbn = {0596514980, 9780596514983}, 50 | edition = {1st}, 51 | publisher = {O'Reilly Media, Inc.}, 52 | } 53 | 54 | @book{plp, 55 | author={Scott, Michael L}, 56 | title={Programming Language Pragmatics, Fouth Edition}, 57 | publisher={Morgan Kaufmann}, 58 | address={Waltham, MA}, 59 | year=2016 60 | } 61 | 62 | @InProceedings{frob, 63 | author ={John Peterson and Paul Hudak and Conal Elliott}, 64 | title = {Lambda in Motion: Controlling Robots with Haskell}, 65 | booktitle = {First International Workshop on Practical Aspects of Declarative Languages~(PADL)}, 66 | year=1999, 67 | month = {January} 68 | } 69 | 70 | @inproceedings{adams2012layout, 71 | author = {Adams, Michael D.}, 72 | title = {Principled Parsing for Indentation-Sensitive Languages: Revisiting {L}andin's Offside Rule}, 73 | booktitle = {Proceedings of the 40th annual ACM SIGPLAN-SIGACT symposium on Principles of programming languages}, 74 | pages = {511--522}, 75 | year = {2013}, 76 | series = {POPL~'13}, 77 | address = {New York, NY, USA}, 78 | publisher = {ACM}, 79 | isbn = {978-1-4503-1832-7}, 80 | doi = {10.1145/2429069.2429129}, 81 | } 82 | 83 | @Inbook{deGroote1995, 84 | author="de Groote, Philippe", 85 | editor="Dezani-Ciancaglini, Mariangiola 86 | and Plotkin, Gordon", 87 | title="A simple calculus of exception handling", 88 | bookTitle="Typed Lambda Calculi and Applications: Second International Conference on Typed Lambda Calculi and Applications, TLCA '95 Edinburgh, United Kingdom, April 10--12, 1995 Proceedings", 89 | year="1995", 90 | publisher="Springer Berlin Heidelberg", 91 | address="Berlin, Heidelberg", 92 | pages="201--215", 93 | isbn="978-3-540-49178-1", 94 | doi="10.1007/BFb0014054", 95 | url="http://dx.doi.org/10.1007/BFb0014054" 96 | } 97 | 98 | @book{Pierce:2002:TPL:509043, 99 | author = {Pierce, Benjamin C.}, 100 | title = {Types and Programming Languages}, 101 | year = {2002}, 102 | isbn = {0262162091, 9780262162098}, 103 | edition = {1st}, 104 | publisher = {The MIT Press}, 105 | } 106 | 107 | @inproceedings{Afshari:2012:LPP:2384592.2384595, 108 | author = {Afshari, Mehrdad and Barr, Earl T. and Su, Zhendong}, 109 | title = {Liberating the Programmer with Prorogued Programming}, 110 | booktitle = {Proceedings of the ACM International Symposium on New Ideas, New Paradigms, and Reflections on Programming and Software}, 111 | series = {Onward! 2012}, 112 | year = {2012}, 113 | isbn = {978-1-4503-1562-3}, 114 | location = {Tucson, Arizona, USA}, 115 | pages = {11--26}, 116 | numpages = {16}, 117 | url = {http://doi.acm.org/10.1145/2384592.2384595}, 118 | doi = {10.1145/2384592.2384595}, 119 | acmid = {2384595}, 120 | publisher = {ACM}, 121 | address = {New York, NY, USA}, 122 | keywords = {executable refinement, human computation, hybrid computation, managing concerns, prorogued programming, workflow improvement}, 123 | } 124 | 125 | @article{Tofte:2004:RRM:993034.993040, 126 | author = {Tofte, Mads and Birkedal, Lars and Elsman, Martin and Hallenberg, Niels}, 127 | title = {A Retrospective on Region-Based Memory Management}, 128 | journal = {Higher Order Symbol. Comput.}, 129 | issue_date = {September 2004}, 130 | volume = {17}, 131 | number = {3}, 132 | month = sep, 133 | year = {2004}, 134 | issn = {1388-3690}, 135 | pages = {245--265}, 136 | numpages = {21}, 137 | url = {http://dx.doi.org/10.1023/B:LISP.0000029446.78563.a4}, 138 | doi = {10.1023/B:LISP.0000029446.78563.a4}, 139 | acmid = {993040}, 140 | publisher = {Kluwer Academic Publishers}, 141 | address = {Hingham, MA, USA}, 142 | keywords = {Standard ML, dynamic storage management, regions}, 143 | } 144 | 145 | @article{Tofte:1998:RIA:291891.291894, 146 | author = {Tofte, Mads and Birkedal, Lars}, 147 | title = {A Region Inference Algorithm}, 148 | journal = {ACM Trans. Program. Lang. Syst.}, 149 | issue_date = {July 1998}, 150 | volume = {20}, 151 | number = {4}, 152 | month = jul, 153 | year = {1998}, 154 | issn = {0164-0925}, 155 | pages = {724--767}, 156 | numpages = {44}, 157 | url = {http://doi.acm.org/10.1145/291891.291894}, 158 | doi = {10.1145/291891.291894}, 159 | acmid = {291894}, 160 | publisher = {ACM}, 161 | address = {New York, NY, USA}, 162 | keywords = {regions, standard ML}, 163 | } 164 | 165 | @incollection{Barendregt:1993:LCT:162552.162561, 166 | author = {Barendregt, H. P.}, 167 | chapter = {Lambda Calculi with Types}, 168 | title = {Handbook of Logic in Computer Science (Vol. 2)}, 169 | editor = {Abramsky, S. and Gabbay, Dov M. and Maibaum, S. E.}, 170 | year = {1992}, 171 | isbn = {0-19-853761-1}, 172 | pages = {117--309}, 173 | numpages = {193}, 174 | url = {http://dl.acm.org/citation.cfm?id=162552.162561}, 175 | acmid = {162561}, 176 | publisher = {Oxford University Press, Inc.}, 177 | address = {New York, NY, USA}, 178 | } 179 | 180 | @book{Lipovaca:2011:LYH:2018642, 181 | author = {Lipovaca, Miran}, 182 | title = {Learn You a Haskell for Great Good!: A Beginner's Guide}, 183 | year = {2011}, 184 | isbn = {1593272839, 9781593272838}, 185 | edition = {1st}, 186 | publisher = {No Starch Press}, 187 | address = {San Francisco, CA, USA}, 188 | } 189 | 190 | @misc{scheme, 191 | author= {Tang, Jonathan}, 192 | title= {Write yourself a Scheme in 48 hours}, 193 | howpublished={\url{https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours}}, 194 | } 195 | 196 | @misc{diehl, 197 | author = {Diehl, Stephen}, 198 | title = {Write you a Haskell}, 199 | howpublished = {\url{http://dev.stephendiehl.com/fun/}}, 200 | } 201 | 202 | @MISC{algoW, 203 | author = {Martin Grabmüller}, 204 | title = {Algorithm W Step by Step}, 205 | howpublished = {\url{https://github.com/mgrabmueller/AlgorithmW}}, 206 | year = {2006} 207 | } 208 | 209 | @misc{transformers, 210 | author = {Martin Grabmuller}, 211 | title = {Transformers Step By Step}, 212 | howpublished = {\url{https://github.com/mgrabmueller/TransformersStepByStep}}, 213 | } 214 | 215 | @book{Pierce:2004:ATT:1076265, 216 | author = {Pierce, Benjamin C.}, 217 | title = {Advanced Topics in Types and Programming Languages}, 218 | year = {2004}, 219 | isbn = {0262162288}, 220 | publisher = {The MIT Press}, 221 | } 222 | 223 | @book{ 9780511608865, 224 | author = "J. Roger Hindley", 225 | title = {Basic Simple Type Theory}, 226 | publisher = {Cambridge University Press}, 227 | year = {1997}, 228 | isbn = {9780511608865}, 229 | note = {Cambridge Books Online}, 230 | url = {http://dx.doi.org/10.1017/CBO9780511608865} 231 | } 232 | 233 | @book{opac-b1078351, 234 | title = "Categories for the working mathematician", 235 | author = "Mac Lane, Saunders", 236 | series = "Graduate texts in mathematics", 237 | publisher = "Springer-Verlag", 238 | address = "New York", 239 | url = "http://opac.inria.fr/record=b1078351", 240 | isbn = "0-387-90036-5", 241 | year = 1971 242 | } 243 | 244 | @book{Abelson:1996:SIC:547755, 245 | author = {Abelson, Harold and Sussman, Gerald J.}, 246 | title = {Structure and Interpretation of Computer Programs}, 247 | year = {1996}, 248 | isbn = {0262011530}, 249 | edition = {2nd}, 250 | publisher = {MIT Press}, 251 | address = {Cambridge, MA, USA}, 252 | } 253 | 254 | 255 | @book{Friedman1900, 256 | edition = {fourth edition}, 257 | howpublished = {Paperback}, 258 | isbn = {0262560992}, 259 | keywords = {lisp, programming, recursion, scheme}, 260 | month = dec, 261 | posted-at = {2011-07-23 03:37:24}, 262 | priority = {2}, 263 | publisher = {The MIT Press}, 264 | title = {{The Little Schemer - 4th Edition}}, 265 | url = {http://www.amazon.com/exec/obidos/redirect?tag=citeulike07-20\&path=ASIN/0262560992}, 266 | year = {1995} 267 | } 268 | 269 | @inproceedings{Wadler:1995:MFP:647698.734146, 270 | author = {Wadler, Philip}, 271 | title = {Monads for Functional Programming}, 272 | booktitle = {Advanced Functional Programming, First International Spring School on Advanced Functional Programming Techniques-Tutorial Text}, 273 | year = {1995}, 274 | isbn = {3-540-59451-5}, 275 | pages = {24--52}, 276 | numpages = {29}, 277 | url = {http://dl.acm.org/citation.cfm?id=647698.734146}, 278 | acmid = {734146}, 279 | publisher = {Springer-Verlag}, 280 | address = {London, UK, UK}, 281 | } 282 | 283 | @article{TUR79a, 284 | author = {Turner, D.}, 285 | citeulike-article-id = {2765535}, 286 | journal = {Software-Practice and Experience}, 287 | keywords = {rcb-bibfile}, 288 | pages = {31--49}, 289 | posted-at = {2008-05-07 12:57:49}, 290 | priority = {2}, 291 | title = {{A New Implementation Technique for Applicative Languages}}, 292 | volume = {9}, 293 | year = {1979} 294 | } 295 | 296 | 297 | @article{citeulike:2570403, 298 | abstract = {{Did you ever wonder how Y works and how anyone could ever have thought of it? Do you feel like a Lisp weakling when some heavy-duty Scheme hacker kicks sand in your face by admiring Y in public? In this note I'll try to explain to you not only how it works, but how someone could have invented it. I'll use Scheme notation because it is easier to understand when functions passed as arguments are being applied. At the end, I'll show you Common Lisp equivalents of some of the Scheme code.}}, 299 | address = {New York, NY, USA}, 300 | author = {Gabriel, Richard P.}, 301 | citeulike-article-id = {2570403}, 302 | citeulike-linkout-0 = {http://portal.acm.org/citation.cfm?id=1317250.1317252}, 303 | citeulike-linkout-1 = {http://dx.doi.org/10.1145/1317250.1317252}, 304 | doi = {10.1145/1317250.1317252}, 305 | issn = {1045-3563}, 306 | journal = {SIGPLAN Lisp Pointers}, 307 | keywords = {calculus, lambda}, 308 | number = {2}, 309 | pages = {15--25}, 310 | posted-at = {2010-05-05 09:04:55}, 311 | priority = {2}, 312 | publisher = {ACM}, 313 | title = {{The why of Y}}, 314 | url = {http://dx.doi.org/10.1145/1317250.1317252}, 315 | volume = {2}, 316 | year = {1988} 317 | } 318 | 319 | @MISC{Marlow_haskell2010, 320 | author = {Simon Marlow}, 321 | title = {Haskell 2010 Language Report}, 322 | year = {2010} 323 | } 324 | 325 | @techreport{958, 326 | author = {Simon Thompson}, 327 | title = {{Regular Expressions and Automata using Haskell}}, 328 | month = {January}, 329 | year = {2000}, 330 | pages = {182-196}, 331 | keywords = {determinacy analysis, Craig interpolants}, 332 | note = {}, 333 | doi = {}, 334 | url = {http://www.cs.kent.ac.uk/pubs/2000/958}, 335 | institution = {Computing Laboratory, University of Kent}, 336 | number = {5-00}, 337 | publication_type = {techreport}, 338 | submission_id = {23260_948360512}, 339 | type = {Technical Report}, 340 | } 341 | 342 | @inproceedings{Steele:1994:BIC:174675.178068, 343 | author = {Steele,Jr., Guy L.}, 344 | title = {Building Interpreters by Composing Monads}, 345 | booktitle = {Proceedings of the 21st ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages}, 346 | series = {POPL '94}, 347 | year = {1994}, 348 | isbn = {0-89791-636-0}, 349 | location = {Portland, Oregon, USA}, 350 | pages = {472--492}, 351 | numpages = {21}, 352 | url = {http://doi.acm.org/10.1145/174675.178068}, 353 | doi = {10.1145/174675.178068}, 354 | acmid = {178068}, 355 | publisher = {ACM}, 356 | address = {New York, NY, USA}, 357 | } 358 | 359 | @TechReport{leijen2001, 360 | Author = {Leijen, Daan}, 361 | Title = {Parsec, a fast combinator parser}, 362 | Number = {35}, 363 | Institution = {Department of Computer Science, University of Utrecht (RUU)}, 364 | Month = {October}, 365 | Year = {2001} 366 | } 367 | 368 | @book{opac-b1081362, 369 | title = "Type theory and functional programming", 370 | author = "Thompson, Simon", 371 | series = "International computer science series", 372 | publisher = "Addison-Wesley", 373 | address = "Wokingham (GB)", 374 | url = "http://opac.inria.fr/record=b1081362", 375 | isbn = "0-201-41667-0", 376 | year = 1991 377 | } 378 | 379 | @techreport{citeulike:4001400, 380 | abstract = {{This standard specifies interchange and arithmetic formats and methods for binary and decimal floating-point arithmetic in computer programming environments. This standard specifies exception conditions and their default handling. An implementation of a floating-point system conforming to this standard may be realized entirely in software, entirely in hardware, or in any combination of software and hardware. For operations specified in the normative part of this standard, numerical results and exceptions are uniquely determined by the values of the input data, sequence of operations, and destination formats, all under user control.}}, 381 | address = {3 Park Avenue, New York, NY 10016-5997, USA}, 382 | booktitle = {IEEE Std 754-2008}, 383 | citeulike-article-id = {4001400}, 384 | citeulike-linkout-0 = {http://dx.doi.org/10.1109/ieeestd.2008.4610935}, 385 | citeulike-linkout-1 = {http://ieeexplore.ieee.org/xpls/abs\_all.jsp?arnumber=4610935}, 386 | day = {29}, 387 | doi = {10.1109/ieeestd.2008.4610935}, 388 | institution = {Microprocessor Standards Committee of the IEEE Computer Society}, 389 | isbn = {978-0-7381-5752-8}, 390 | journal = {IEEE Std 754-2008}, 391 | keywords = {ch3, gpgpu}, 392 | month = aug, 393 | organization = {Microprocessor Standards Committee of the IEEE Computer Society}, 394 | pages = {1--70}, 395 | posted-at = {2009-08-01 03:34:26}, 396 | priority = {2}, 397 | publisher = {The Institute of Electrical and Electronics Engineers, Inc.}, 398 | title = {{IEEE Standard for Floating-Point Arithmetic}}, 399 | url = {http://dx.doi.org/10.1109/ieeestd.2008.4610935}, 400 | year = {2008} 401 | } 402 | 403 | @article{Loh:2010:TID:1883634.1883637, 404 | author = {L\"{o}h, Andres and McBride, Conor and Swierstra, Wouter}, 405 | title = {A Tutorial Implementation of a Dependently Typed Lambda Calculus}, 406 | journal = {Fundam. Inf.}, 407 | issue_date = {April 2010}, 408 | volume = {102}, 409 | number = {2}, 410 | month = apr, 411 | year = {2010}, 412 | issn = {0169-2968}, 413 | pages = {177--207}, 414 | numpages = {31}, 415 | url = {http://dl.acm.org/citation.cfm?id=1883634.1883637}, 416 | acmid = {1883637}, 417 | publisher = {IOS Press}, 418 | address = {Amsterdam, The Netherlands, The Netherlands}, 419 | } 420 | 421 | @article{cardelli1984basic, 422 | author = {Cardelli, L.}, 423 | citeulike-article-id = {9340062}, 424 | journal = {Science of Computer Programming}, 425 | posted-at = {2011-05-26 12:53:32}, 426 | priority = {2}, 427 | publisher = {Citeseer}, 428 | title = {{Basic polymorphic typechecking}}, 429 | volume = {8}, 430 | year = {1984} 431 | } 432 | 433 | @inbook{scott, 434 | author = {Scott, Dana}, 435 | citeulike-article-id = {11840616}, 436 | citeulike-linkout-0 = {http://dx.doi.org/10.1016/s0049-237x(08)71262-x}, 437 | doi = {10.1016/s0049-237x(08)71262-x}, 438 | isbn = {9780444853455}, 439 | keywords = {lambda}, 440 | pages = {223--265}, 441 | posted-at = {2012-12-12 13:17:26}, 442 | priority = {2}, 443 | publisher = {Elsevier}, 444 | title = {{Lambda Calculus: Some Models, Some Philosophy}}, 445 | url = {http://dx.doi.org/10.1016/s0049-237x(08)71262-x}, 446 | volume = {101}, 447 | year = {1980} 448 | } 449 | -------------------------------------------------------------------------------- /docs/codeSamples.tex: -------------------------------------------------------------------------------- 1 | The following code extracts do not represent the complete code for microML. The interested reader is 2 | referred to the repository on github \url{https://github.com/kellino/microML} or to the source code 3 | included in the submission. 4 | 5 | \subsubsection{Repl.hs} 6 | The most complete entry point for the language, the repl environment, is partially listed here 7 | \lstinputlisting[language=haskell, showstringspaces=false, basicstyle=\tiny, firstline=44]{../src/Repl/Repl.hs} 8 | 9 | \subsubsection{CallGraph.hs} 10 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, basicstyle=\tiny, firstline=20]{../src/Compiler/CallGraph.hs} 11 | 12 | \subsubsection{Type checking of built-in functions} 13 | Primitive operators and functions, such as head and tail are not available to the inference engine. 14 | Therefore it was necessary to `hard code' the type signatures into the environment, thereby allowing 15 | students to check the type signature of various important functions, but also meaning that these 16 | functions can now be type checked\footnote{Haskell overcomes this problem partially by having almost 17 | everything as a library function, including such things as + and -, which in microML are 18 | primitives.}. Figure~\ref{fig:typesigs} 19 | 20 | \begin{figure}[H] 21 | \begin{minted}[breaklines=true]{haskell} 22 | ("show" , Forall [polyA] (TVar polyA `TArrow` typeString)) 23 | , ("read" , Forall [] (typeString `TArrow` typeNum)) 24 | , ("ord" , Forall [] (typeChar `TArrow` typeNum)) 25 | , ("chr" , Forall [] (typeNum `TArrow` typeChar)) 26 | \end{minted} 27 | \caption{Hard-coded type signatures, in Data.Map form} 28 | \label{fig:typesigs} 29 | \end{figure} 30 | 31 | \subsubsection{Lexer.hs} 32 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, firstline=13, basicstyle=\tiny]{../src/MicroML/Lexer.hs} 33 | 34 | \subsubsection{Parser.hs} 35 | An example of a parser written with parser combinators. Complex regular expressions have been replaced with small 36 | regular expressions and other parser combinators. 37 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, firstline=23, basicstyle=\tiny]{../src/MicroML/Parser.hs} 38 | 39 | \subsubsection{Floating Point Representation} 40 | Truncating floating-point representation in the repl is done using string manipulation. The choice 41 | of three consecutive 0s is largely arbitrary. See Figure~\ref{fig:trunc} and 42 | Section~\ref{floatingPoint}. 43 | \begin{figure} 44 | \begin{minted}[breaklines=true]{haskell} 45 | truncate' :: Double -> Double 46 | truncate' = read . dropZeros . show 47 | where dropZeros x = head (split x) ++ "." ++ getValid (head (tail (split x))) 48 | split = splitOn "." 49 | getValid s 50 | | "e" `isInfixOf` s = s 51 | | hasform s = if length s == 1 then s else show $ read [head s] + 1 52 | | take 3 s == "000" = "0" 53 | | otherwise = head s : getValid (tail s) 54 | 55 | hasform :: String -> Bool 56 | hasform (_:ys) = all (== '9') ys 57 | \end{minted} 58 | \caption{The truncation function for doubles in the repl} 59 | \label{fig:trunc} 60 | \end{figure} 61 | 62 | \subsubsection{Unit Testing\@: ListPrimitivesSpec.hs} 63 | Unit testing was conducted with the HSpec package\footnote{\url{https://hspec.github.io/}}. 64 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, basicstyle=\tiny]{../test/ListPrimitivesSpec.hs} 65 | 66 | \subsubsection{Eval.hs} 67 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, firstline=10, 68 | basicstyle=\tiny]{../src/Repl/Eval.hs} 69 | 70 | \subsubsection{Infer.hs} 71 | \lstinputlisting[language=haskell, breaklines=true, showstringspaces=false, firstline=25, basicstyle=\tiny]{../src/MicroML/Typing/Infer.hs} 72 | 73 | 74 | \section{Utilities} 75 | MicroML also ships with a number of utility scripts. 76 | The installation script is written in bash\footnote{The script makes use of bash arrays so it is not 77 | 100\% posix compatible. As \textit{dash} has now become the standard shell on Ubuntu future 78 | iterations might need to take this into account.}. 79 | \lstinputlisting[language=bash, breaklines=true, showstringspaces=false, basicstyle=\tiny]{../installMicroML} 80 | 81 | MicroML also has a simple (neo)vim plugin which ships with the repo. The folding function is of some 82 | interest, as it autofolds comments, setting the function name as its `title'. See 83 | Figures~\ref{fig:fold} and~\ref{fig:foldVim} 84 | 85 | \begin{figure} 86 | \begin{minted}[breaklines=true]{vim} 87 | function! GetMMLFold(lnum) 88 | let l:line = getline( a:lnum ) 89 | " Beginning of comment 90 | if l:line =~? '\v^\s*--' || l:line =~? '\v^\s*(\*' 91 | return '2' 92 | endif 93 | if l:line =~? '\v^\s*$' 94 | let l:nextline = getline(a:lnum + 1) 95 | if l:nextline =~# '^--' || l:nextline =~? '^(\*' 96 | return '0' 97 | else 98 | return '-1' 99 | endif 100 | endif 101 | return '1' 102 | endfunction 103 | \end{minted} 104 | \caption{Part of the folding function for vim} 105 | \label{fig:fold} 106 | \end{figure} 107 | -------------------------------------------------------------------------------- /docs/diary.tex: -------------------------------------------------------------------------------- 1 | \section{Formalities} 2 | 3 | \textbf{Thursday 26 May} --- Dean asks about group. \\ 4 | \textbf{Friday 27 May} --- inducted into micro:bit team \\ 5 | --- Dean confirms functional project as carte blanche \\ 6 | --- start research into an ml style language \\ 7 | \textbf{Saturday 28 May} --- decide to target micropython with a Haskell compiler \\ 8 | \textbf{Sunday 29 May} --- comparison of functional languages \\ 9 | \textbf{Tuesday 31 May} --- meeting with Rae at 2:30 \\ 10 | \textbf{} --- discussed making a dsl for micro:bit. Need to justify educational value. \\ 11 | \textbf{} --- Focus on robotics. Wants a doc detailing requirements and constraints of design. \\ 12 | \textbf{Wednesday 1 June} --- started drafting initial report for Rae and Peli. Hope to send tomorrow \\ 13 | \textbf{Thursday 2 June} --- sent initial proposal to Rae and Peli \\ 14 | 15 | \section{Project Start} 16 | 17 | \textbf{Wednesday 8 June} --- finally hear from Rae, who is happy with the proposal. Still no word from Peli. \\ 18 | \textbf{} --- meeting scheduled for tomorrow morning. \\ 19 | \textbf{} --- Started tutorial for CoreLang (SPJ) which looks a promising base for microML \\ 20 | \textbf{Thursday 9 June} --- morning meeting with Rae, details of which (prepare examples of 21 | backends) are superseded by emails from Peli and Tom Ball, recommending using the C++ API as target language. \\ 22 | \textbf{Friday 10 June} --- started work in microML parser. Research Text.Indentation and Trifecta \\ 23 | \textbf{Sunday 12 June} --- basic work on simple parser and repl done. Only parses one line of input. \\ 24 | \textbf{Monday 13 June} --- started rewriting using megaparsec. Good progress made. Reused repl code \\ 25 | \textbf{Tuesday 14 June} --- implemented lambda parsing and most of type signature parsing. Indentation still to do \\ 26 | \textbf{Wednesday 15 June} --- tuples added to parser and type signatures fixed. Type aliasing added. File reading still not working \\ 27 | \textbf{Thursday 16 June} --- more work on parser \\ 28 | \textbf{Friday 17 June} --- started work on evaluation for repl. Arithmetic done and simple boolean operators \\ 29 | \textbf{Monday 20 June} --- little progress. Still can't store values in the repl \\ 30 | \textbf{Tuesday 21 June} --- started refactoring code, removing all problematic elements \\ 31 | \textbf{Wednesday 22 June} --- repl finally working, moving on to type inference \\ 32 | \textbf{Thursday 23 June} --- starting writing tests, using Hspec, for parser/lexer \\ 33 | \textbf{Friday 24 June} --- recursion now working, but syntax needs to be improved \\ 34 | \textbf{Monday 27 June} --- working on pattern matching and simple type inference \\ 35 | \textbf{Tuesday 28 June} --- as above \\ 36 | \textbf{Wednesday 29 June} --- simple type inference almost working but needs to be extended. Pattern matching parser working, \\ 37 | but no supporting algorithm of language support yet. \\ 38 | \textbf{Thursday 30 June} --- fixed type inference for numbers (a slight hack here, only allowing a Num type) \\ 39 | \textbf{Friday 1 July} --- working on lists. Need to rewrite the interpreter. Then finish on this part. Removed pattern matching. \\ 40 | Simplified pretty printer. \\ 41 | \textbf{Monday 4 July} --- recursion on lists is finally working. Once type inference on lists work, we can move on to compilation \\ 42 | \textbf{Tuesday 5 July} --- cons operator is working. Now only list type inference is major outstanding feature of repl. \\ 43 | \textbf{Wednesday 6 July} --- type inference now working on lists. Started writing Github wiki. \\ 44 | \textbf{Thursday 7 July} --- meeting with Rae. Agreed to start writing up progress. Start debugging. \\ 45 | \textbf{Monday 11 July} --- exception handling added to inference module, not yet complete \\ 46 | \textbf{Wednesday 13 July} --- refactored primitive ops so that sqrt and others are now properly typechecked \\ 47 | \textbf{Thursday 14 July} --- very little done. Meeting with Rae. ord, chr, toUpper and toLower. Start of string library \\ 48 | \textbf{Friday 15 July} --- added command line arguments to main program. Successfully compiled hello world! \\ 49 | \textbf{Sunday 17 July} --- fixed bug in string literal printing \\ 50 | \textbf{Tuesday 19 July} --- started work on new version of compiler. Simple functions work \\ 51 | \textbf{Wednesday 20 July} --- finally starting to understand Monad transformers after doing 52 | tutorial. Added ExceptT to compiler module :) \\ 53 | \textbf{Thursday 21 July} --- started adding type inference to compiler. Lots of small bugs fixed. \\ 54 | \textbf{Friday 22 July} --- more error handling, for mod, head and tail, also ord and chr (though they can't be typechecked) \\ 55 | \textbf{Monday 25 July} --- finally fixed list type inference, including nested lists \\ 56 | \textbf{Tuesday 26 July} --- fixed pretty printing of lists. Standard library typechecks but is too general. \\ 57 | \textbf{Monday 1 August} --- type inference also completely fixed. Only lists left to go (or so it seems) \\ 58 | \textbf{Tuesday 2 August} --- lists still not working as expected. A slow day \\ 59 | \textbf{Wednesday 3 August} --- fresh start on compiler. Good progress made with error messages. \\ 60 | \textbf{Thursday 4 August} --- started working on elixir style docs. Wrote small markdown parser \\ 61 | \textbf{Friday 5 August} --- numerous small bug fixes, but docs not quite working yet. Must move on to compiler!! \\ 62 | \textbf{Monday 8 August} --- docs fixed. Compiler now refuses to compile if main is missing, or if there are \\ 63 | duplicate definitions, or if a function is unreachable. All with appropriate error messages. Shell \\ 64 | escape in repl now has proper error handling. :clear added as independent function. Wrote docs for standard.mml \\ 65 | Removed some unreachable code from Infer.hs and improved error handling. A good day. \\ 66 | \textbf{Tuesday 9 August} --- little progress made. Abandoning c-dsl \\ 67 | \textbf{Wednesday 10 Aug} --- new version of compiler started, much simpler but appears to be working. Also \\ 68 | added typesigs for built-in functions --- this might be a good way to infer lambdas \\ 69 | \textbf{Thursday 11 Aug} --- improved callgraph. Changed to using stack as a build tool. Had to remove llvm \\ 70 | as a result \\ 71 | \textbf{Friday 12 Aug} --- restarted compiler again, this time using ExceptT and monad stack (as per transformers tutorial) \\ 72 | \textbf{Monday 15 Aug} --- using RWST for compiler. Added dotfile production of callgraph. Compiler (though primitive) working as proof of concept. \\ 73 | \textbf{Tuesday 16 Aug} --- added pst command, with a nice pretty printed parse tree in the repl, 74 | complete with error handling. \\ 75 | \textbf{Wednesday 17 Aug} --- added clang ---format for file. Added typeEnv into Compiler monad, but not yet working as expected \\ 76 | \textbf{Thursday 18 Aug} --- wrote folding method for microML in vim. Started write up of report \\ 77 | \textbf{Friday 19 Aug} --- worked on report. Used tikz for the first time in latex. \\ 78 | \textbf{Monday 22 Aug} --- worked on report \\ 79 | \textbf{Tuesday 23 Aug} --- worked on report. Wrote simple bash script to run compiler tests. Wrote unit \\ 80 | tests for ListPrimitives. Bash script to compile latex with bibliography \\ 81 | \textbf{Wednesday 24 Aug} --- writing \\ 82 | -------------------------------------------------------------------------------- /docs/glossary.tex: -------------------------------------------------------------------------------- 1 | \newglossaryentry{BNF} 2 | {% 3 | name=BNF, 4 | description={Backus Naur Form} 5 | } 6 | 7 | \newglossaryentry{dependent types} 8 | {% 9 | name={dependent types}, 10 | description={A type whose definition depends on a value} 11 | } 12 | 13 | \newglossaryentry{Coq} 14 | {% 15 | name=Coq, 16 | description={A proof assistant written in OCaml} 17 | } 18 | 19 | \newglossaryentry{parametric polymorphism} 20 | {% 21 | name={parametric polymorphism}, 22 | description={a way of writing generic functions so that they can handle any data type} 23 | } 24 | 25 | \newglossaryentry{duck typing} 26 | {% 27 | name={duck typing}, 28 | description={a form of runtime typing where a object is tested for its suitability for a task, 29 | rather than its exact nature} 30 | } 31 | 32 | \newglossaryentry{DSL} 33 | {% 34 | name={DSL}, 35 | description={Domain Specific Language} 36 | } 37 | 38 | \newglossaryentry{lts} 39 | {% 40 | name={lts}, 41 | description={Long Term Support} 42 | } 43 | 44 | \newglossaryentry{ADT} 45 | {%% 46 | name={ADT}, 47 | description={Algebraic Data Type} 48 | } 49 | 50 | \newglossaryentry{strict} 51 | {% 52 | name={strict}, 53 | description={a language is strict if it always evaluates all of the parameters passed to a 54 | function. A non-strict, or lazy, language, only evaluates what is specifically required} 55 | } 56 | 57 | \newglossaryentry{DAG} 58 | {% 59 | name={DAG}, 60 | description={a directed acyclic graph} 61 | } 62 | 63 | \newglossaryentry{totality} 64 | {% 65 | name={totality}, 66 | description={a function is \textit{total} which has a legal output for every legal input, i.e.\ an output is 67 | defined for all possible input} 68 | } 69 | 70 | \newglossaryentry{ghci} 71 | {% 72 | name={ghci}, 73 | description={the Glasgow Haskell Compiler's repl environment} 74 | } 75 | -------------------------------------------------------------------------------- /docs/images/callgraph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/callgraph.png -------------------------------------------------------------------------------- /docs/images/comment.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/comment.jpg -------------------------------------------------------------------------------- /docs/images/help.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/help.jpg -------------------------------------------------------------------------------- /docs/images/logo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/logo.jpg -------------------------------------------------------------------------------- /docs/images/modulo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/modulo.jpg -------------------------------------------------------------------------------- /docs/images/odd.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/odd.jpg -------------------------------------------------------------------------------- /docs/images/parsetext.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/parsetext.jpg -------------------------------------------------------------------------------- /docs/images/pipe.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/pipe.jpg -------------------------------------------------------------------------------- /docs/images/randomBanner.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/randomBanner.jpg -------------------------------------------------------------------------------- /docs/images/tree.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/tree.jpg -------------------------------------------------------------------------------- /docs/images/typeError.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/typeError.jpg -------------------------------------------------------------------------------- /docs/images/vim.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kellino/microML/26a4e0ad7542e26f51945eb92db19f63f69b6962/docs/images/vim.jpg -------------------------------------------------------------------------------- /docs/libs.tex: -------------------------------------------------------------------------------- 1 | The standard libraries are arranged as follows: 2 | 3 | \begin{table}[H] 4 | \begin{tabular}{l r} 5 | \rowcolor{light-gray} 6 | \textbf{combinators} & \\ 7 | Function & Type Signature \\ 8 | \hline 9 | tr & $\forall a b. a \rightarrow b \rightarrow a$ \\ 10 | fls & $\forall a b. a \rightarrow b \rightarrow b$ \\ 11 | not' & $\forall a b c d e. ((a \rightarrow b \rightarrow a) \rightarrow (c \rightarrow d \rightarrow d) \rightarrow e) \rightarrow e$ \\ 12 | and' & $\forall a b c d. (a \rightarrow (b \rightarrow c \rightarrow c) \rightarrow d) \rightarrow a \rightarrow d$ \\ 13 | or' & $\forall a b c d. ((a \rightarrow b \rightarrow a) \rightarrow c \rightarrow d) \rightarrow c \rightarrow d$ \\ 14 | cond & $\forall a b c. (a \rightarrow b \rightarrow c) \rightarrow a \rightarrow b \rightarrow c$ \\ 15 | i & $\forall a. a \rightarrow a \rightarrow a$ \\ 16 | k & $\forall a b. a \rightarrow b \rightarrow a$ \\ 17 | s & $\forall a b c. (a \rightarrow b \rightarrow c) (a \rightarrow b) \rightarrow a \rightarrow c$ \\ 18 | mu & $\forall a. (a \rightarrow a) \rightarrow a$ \\ 19 | b & $\forall a b c. (a \rightarrow b) \rightarrow (c \rightarrow a) \rightarrow c \rightarrow b$\\ 20 | c & $\forall a b c. (a \rightarrow b \rightarrow c) \rightarrow b \rightarrow a \rightarrow b$ \\ 21 | w & $\forall a b. (a \rightarrow a \rightarrow b) \rightarrow a \rightarrow b$ \\ 22 | \end{tabular} 23 | \caption{Combinators library} 24 | \label{table:combinators} 25 | \end{table} 26 | 27 | \begin{longtable}{l r} 28 | \rowcolor{light-gray} 29 | \textbf{standard} & \\ 30 | Function & Type Signature \\ 31 | \hline 32 | head & $\forall a. [a] \rightarrow a$ \\ 33 | tail & $\forall a. [a] \rightarrow [a]$ \\ 34 | id & $\forall a \rightarrow a$ \\ 35 | zero? & $Number \rightarrow Boolean$ \\ 36 | odd? & $Number \rightarrow Boolean$ \\ 37 | even? & $Number \rightarrow Boolean$ \\ 38 | positive? & $Number \rightarrow Boolean$ \\ 39 | negative? & $Number \rightarrow Boolean$ \\ 40 | show & $\forall a. a \rightarrow String$ \\ 41 | read & $String \rightarrow Number$ \\ 42 | const & $\forall a b. a \rightarrow b$ \\ 43 | succ & $Number \rightarrow Number$ \\ 44 | flip & $\forall a b c. (a \rightarrow b \rightarrow c) \rightarrow b \rightarrow a \rightarrow c$ \\ 45 | twice & $\forall a. (a \rightarrow a) \rightarrow a \rightarrow a$ \\ 46 | pipe & $\forall a b. a \rightarrow a (a \rightarrow b) \rightarrow b$ \\ 47 | compose & $\forall a b c. (a \rightarrow b) \rightarrow (c \rightarrow a) \rightarrow c \rightarrow b$\\ 48 | empty? & $Number \rightarrow Boolean$ \\ 49 | length & $\forall a. [a] \rightarrow Number$ \\ 50 | drop & $\forall a. Number \rightarrow [a] \rightarrow [a]$ \\ 51 | take & $\forall a. Number \rightarrow [a] \rightarrow [a]$ \\ 52 | foldr & $\forall a b. (a \rightarrow b \rightarrow b) \rightarrow b \rightarrow [a] \rightarrow b$\\ 53 | foldl & $\forall a b. (b \rightarrow a \rightarrow b) \rightarrow b \rightarrow [a] \rightarrow b$\\ 54 | foldr1 & $\forall a. (a \rightarrow a \rightarrow a) \rightarrow [a] \rightarrow a$\\ 55 | foldl1 & $\forall a. (a \rightarrow a \rightarrow a) \rightarrow [a] \rightarrow a$\\ 56 | map & $\forall a b. (a \rightarrow b) \rightarrow [a] \rightarrow [b]$ \\ 57 | filter & $\forall a. (a \rightarrow Boolean) \rightarrow [a] \rightarrow [a] $\\ 58 | init & $\forall a. [a] \rightarrow [a]$ \\ 59 | reverse & $\forall a. [a] \rightarrow [a]$ \\ 60 | last & $\forall a. [a] \rightarrow a$ \\ 61 | quicksort & $\forall a. [a] \rightarrow [a]$ \\ 62 | mergesort & $\forall a. [a] \rightarrow [a]$ \\ 63 | \caption{Standard library} 64 | \label{table:standard} 65 | \end{longtable} 66 | 67 | \begin{longtable}{l r} 68 | \rowcolor{light-gray} 69 | \textbf{maths} & \\ 70 | Function & Type Signature \\ 71 | \hline 72 | pi & $Number$ \\ 73 | e & $Number$ \\ 74 | abs & $Number \rightarrow Number$ \\ 75 | negate & $Number \rightarrow Number$ \\ 76 | max & $Number \rightarrow Number \rightarrow Number$ \\ 77 | min & $Number \rightarrow Number \rightarrow Number$ \\ 78 | intToFloat & $Number \rightarrow Number$ \\ 79 | reciprocal & $Number \rightarrow Number$ \\ 80 | square & $Number \rightarrow Number$ \\ 81 | sqrt & $Number \rightarrow Number$ \\ 82 | sum & $[Number] \rightarrow Number$ \\ 83 | product & $[Number] \rightarrow Number$ \\ 84 | floor & $Number \rightarrow Number$ \\ 85 | ceiling & $Number \rightarrow Number$ \\ 86 | floattoInt & $Number \rightarrow Number$ \\ 87 | ln & $Number \rightarrow Number$ \\ 88 | log2 & $Number \rightarrow Number$ \\ 89 | log10 & $Number \rightarrow Number$ \\ 90 | logBase & $Number \rightarrow Number$ \\ 91 | radians & $Number \rightarrow Number$ \\ 92 | sin & $Number \rightarrow Number$ \\ 93 | cos & $Number \rightarrow Number$ \\ 94 | tan & $Number \rightarrow Number$ \\ 95 | arcsin & $Number \rightarrow Number$ \\ 96 | arccos & $Number \rightarrow Number$ \\ 97 | arctan & $Number \rightarrow Number$ \\ 98 | fib & $Number \rightarrow Number$ \\ 99 | factorial & $Number \rightarrow Number$ \\ 100 | ceiling & $Number \rightarrow Number$ \\ 101 | gcd & $Number \rightarrow Number \rightarrow Number$ \\ 102 | \caption{Maths library} 103 | \label{table:maths} 104 | \end{longtable} 105 | 106 | \begin{table}[H] 107 | \begin{tabular}{l r} 108 | \rowcolor{light-gray} 109 | \textbf{string} & \\ 110 | Function & Type Signature \\ 111 | \hline 112 | chr & $Number \rightarrow Char$ \\ 113 | ord & $Char \rightarrow Number$ \\ 114 | toUpper & $Char \rightarrow Char$ \\ 115 | toLower & $Char \rightarrow Char$ \\ 116 | pack & $[Char] \rightarrow String$ \\ 117 | \end{tabular} 118 | \caption{String library} 119 | \label{table:string} 120 | \end{table} 121 | \textbf{church} contains the first ten peano numbers only, and a function to test for the zero 122 | value. 123 | -------------------------------------------------------------------------------- /docs/markdown.tex: -------------------------------------------------------------------------------- 1 | An example comment is taken from the standard library is seen in Figure~\ref{fig:odd} 2 | 3 | \begin{figure} 4 | \begin{minted}{sml} 5 | (* 6 | ==odd?== 7 | ***odd?*** 8 | ** odd? :: Number -> Boolean ** 9 | odd? checks if a number is odd, 10 | returning a __boolean__ value. 11 | \#Example:\# 12 | > odd? 5 13 | > true : Boolean 14 | > odd? 4 15 | > false : Boolean 16 | *) 17 | \end{minted} 18 | \caption{Markdown comment for the standard library function odd?} 19 | \label{fig:odd} 20 | \end{figure} 21 | 22 | \begin{figure} 23 | \includegraphics[width=\textwidth]{images/odd.jpg} 24 | \caption{odd? as seen in the terminal} 25 | \label{fig:oddterm} 26 | \end{figure} 27 | 28 | \begin{itemize} 29 | \item a \textbf{comment} begins with `(*' and ends with `*)' 30 | \item the \textbf{comment name} is surrounded with `=='. This is the lookup string for the repl 31 | search. 32 | \item the \textbf{repl title} is surrounded with `***'. This text will be highlighted by a yellow 33 | bar in the repl. 34 | \item text to be rendered \textbf{bold} is surrounded with `**' 35 | \item text to be \underline{underlined} is surrounded with `__' 36 | \item headers are surrounded with `\#' 37 | \item plain text is left without markup. 38 | \end{itemize} 39 | 40 | While not enforced by the syntax itself, underlined words are those which can be found in the 41 | glossary. The glossary is a list of words, written with this markup, which might be unfamiliar to 42 | students. 43 | -------------------------------------------------------------------------------- /docs/mmlcode.tex: -------------------------------------------------------------------------------- 1 | As far as possible, higher-order functions within the standard library are written with `foldr' as a 2 | base. This provides a constant interface for all forms of list manipulation, and as such acts as the 3 | higher-order `primitive' for microML\@. Figure~\ref{fig:foldr} 4 | 5 | \begin{figure}[H] 6 | \begin{minted}[breaklines=true]{sml} 7 | let foldr f acc xs = if empty? xs then acc else ((f (head xs)) (foldr f acc (tail xs))) 8 | let map f xs = foldr (\x xs' -> (f x) : xs') [] xs 9 | let filter p xs = foldr (\x y -> if (p x) then (x:y) else y) [] xs 10 | let foldr1 f xs = foldr f (head xs) xs 11 | \end{minted} 12 | \caption{foldr in the standard library} 13 | \label{fig:foldr} 14 | \end{figure} 15 | 16 | Logs, for reasons of efficiency, are primitives in the language, however other maths functions can 17 | be written quite comfortably in microML. 18 | 19 | \begin{figure} 20 | \begin{minted}[breaklines=true]{sml} 21 | let sin x = 22 | if x == 90 then 1 -- because of rounding errors, let's cheat a little here 23 | else if x == 180 then 0 24 | else let y = (x / 180) * pi 25 | in y - (y^3 / 6) + (y^5 / 120) - (y^7 / 5070) + (y^9 / 362880) - (y^11 / 39916800) 26 | -- hard code the factorials for efficiency 27 | 28 | let cos x = 29 | if x == 180 then (-1) 30 | else sin (90 - x) 31 | 32 | let tan x = (sin x) / (cos x) 33 | \end{minted} 34 | \caption{Sine, cosine and tan in microML} 35 | \label{fig:maths} 36 | \end{figure} 37 | -------------------------------------------------------------------------------- /docs/progressreport.latex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt, a4paper]{article} 2 | \usepackage[utf8]{inputenc} 3 | \usepackage[english]{babel} 4 | \usepackage{syntax} 5 | \usepackage{palatino} 6 | \usepackage{amsmath} 7 | \usepackage{geometry} 8 | \usepackage[hidelinks]{hyperref} 9 | \usepackage{minted} 10 | \usepackage{color, colortbl} 11 | \definecolor{Seagreen}{rgb}{0.18, 0.54, 0.34} 12 | \definecolor{Lawngreen}{rgb}{0.48, 0.99, 0} 13 | \definecolor{LRed}{rgb}{1, 0.8, 0.8} 14 | \definecolor{GoldenRod}{rgb}{0.93, 0.65, 0.12} 15 | \geometry{a4paper, left=25mm, right=25mm, top=1cm, bottom=2cm} 16 | 17 | \begin{document} 18 | \title{Interim Progress Report on microML for the BBC micro:bit} 19 | \date{12 July 2016} 20 | \large\author{David Kelly} 21 | 22 | \maketitle 23 | 24 | \section{microMl for the micro:bit} 25 | 26 | \textit{microML} is a simple functional programming language, inspired by Scheme and Miranda, which 27 | compiles to C++ for the BBC micro:bit microprocessor, and has a repl environment for interactive 28 | code development. There is also a highly experimental JIT compiler using LLVM as a back-end. 29 | 30 | The code can be found at \url{https://github.com/kellino/microML}. The master branch is usually the 31 | most stable, but is not guaranteed to be a working implementation at this stage of development. 32 | 33 | \section{Underpinnings: Enriched Lambda Calculus} 34 | 35 | microML uses an enriched lambda calculus as its base 36 | \vspace{5mm} 37 | 38 | \begin{minipage}[t]{0.5\textwidth} 39 | \begin{grammar} 40 | \::= Var 41 | \alt{} Constructor 42 | \alt{} Application 43 | \alt{} Let Name 44 | \alt{} Literal 45 | \alt{} List [] 46 | \alt{} If then else 47 | \alt{} FixPoint 48 | \alt{} UnaryOp 49 | \alt{} BinOp 50 | \alt{} PrimitiveErr 51 | \end{grammar} 52 | \end{minipage} 53 | \begin{minipage}[t]{0.5\textwidth} 54 | \begin{grammar} 55 | \::= Integer 56 | \alt{} Double 57 | \alt{} Boolean 58 | \alt{} String 59 | \alt{} Char 60 | \alt{} Tuple of 61 | \end{grammar} 62 | \end{minipage} 63 | \vspace{5mm} 64 | 65 | In addition to these basic primitives and control structures, microML also makes use of three 66 | primitives inherited from languages in the Lisp family: 67 | 68 | \begin{grammar} 69 | \::= Car 70 | \alt{} Cdr 71 | \alt{} Cons 72 | \end{grammar} 73 | 74 | These primitives are accessed through the \textit{head}, \textit{tail} and (:) built-in functions and are 75 | essential for recursing over lists.\ 76 | 77 | microML, in addition to floats and ints, also supports binary, octal and hex numbers\footnote{The 78 | syntax for these is inspired by erlang, one simply writes the number in the form eg 2\#110 for a 79 | binary 6. Likewise octal is 8\# and hex 16\#}. These are not 80 | treated as primitives however, and are automatically converted to an appropriate representation. 81 | 82 | The \textit{FixPoint} primitive allows for the creation of recursive functions by satisfying the equation 83 | \begin{flalign*} 84 | &y\ f\ = f (y\ f) & 85 | \end{flalign*} 86 | 87 | The most famous fix-point combinator without a doubt is Curry's \textit{Y-combinator}: 88 | \begin{flalign*} 89 | &Y = (\lambda f. (\lambda x.\ f (x x)) (\lambda x.\ f (x x))) & 90 | \end{flalign*} 91 | 92 | To see how this can be used to simulate recursion\footnote{there are many excellent texts which 93 | give detailed explanations of the \textit{Y-combinator}, such as \dots } it is necessary simply 94 | to supply an argument in the form of a lambda abstraction. 95 | 96 | \begin{eqnarray*} 97 | && Y g = (\lambda f. (\lambda x.\ f (x x)) (\lambda x.\ f (x x))) g \\ 98 | & \to_\beta & (\lambda x.\ g (x x)) (\lambda x.\ g (x x)) \\ 99 | & \to_\beta & g ((\lambda x.\ g (x x)) (\lambda x.\ g (x x))) \\ 100 | & \equiv & g (Y g) 101 | \end{eqnarray*} 102 | 103 | While two different number types are supported by the parser, the type checker only recognizes the 104 | type \textit{Number}. The compiler will benefit from knowledge of the number type, ie int or double, 105 | whereas the user (a school-aged student) will not. 106 | 107 | \section{Parsing} 108 | A number of different libraries were examined before settling on the `standard' 109 | \textit{Parsec} library of parser combinators\footnote{A combinator is a lambda expression which 110 | contains no occurrences of a free variable, ie all of its arguments are 111 | explicitly supplied to it, and it does not rely on any global state or globally defined 112 | variables}. \textit{Parsec} is a highly 113 | flexible tool, perhaps more similar to \textit{ANTLR}\footnote{\url{http://www.antlr.org/}} than to 114 | \textit{Yacc} or \textit{Bison}. Explicit regular expressions are not required, as the parser / 115 | lexer is a composite of a great number of small, specialized parser functions, which are linked 116 | together. If one parser fails, the next is tried until either parsing succeeds or a fatal error 117 | occurs. 118 | 119 | Other libraries, such as \textit{MegaParsec} and \textit{Trifecta}, both respected and 120 | powerful, were examined. Trifecta especially seems like a very interesting parsing library, 121 | with excellent support for detailed, custom error messages. This would have been ideal for a 122 | teaching language of the nature of microML: unfortunately there is an almost total absence of 123 | documentation on the use of Trifecta, and internet tutorials of any size beyond the trivial 124 | do not seem to exist. The programming 125 | language \textbf{Idris} uses Trifecta for its parser, so future iterations of microML might be able 126 | to migrate to Trifecta after careful examination of the Idris source. 127 | 128 | MegaParsec has excellent 129 | support for indentation sensitive grammars, which Parsec does not. Again, this would be a useful 130 | feature to add to microML at a later stage of development. It seems to be however, at the present time, misplaced 131 | energy to focus on what is essentially syntactic sugar when other, more vital, elements of the 132 | project are still not functioning as they should or have not even been started. Moreover, MegaParsec 133 | is a relatively new, and non-standard, library whereas most installations of Haskell ship with 134 | Parsec as a component of the standard library. Of course, eschewing the new in favour of that which 135 | is ubiquitous (often in the name of backwards compatibility) is a bad habit which retards the 136 | development of better software. In this case however, the added power of MegaParsec is not yet 137 | required. 138 | 139 | Formally, parsec belongs to the family of LL(1) parsers. Obviously this does slightly reduce the 140 | flexibility of the language design\footnote{LL(1) parsers can only recognize a subset of the 141 | context-free languages.}. Haskell itself does not use an LL(1) parser, but rather an LALR(1) 142 | built using \textit{Happy} and \textit{Alex}, much in the manner of a parser constructed using 143 | \textit{Yacc}, but such power is not required for the much more limited range of expression 144 | available in microML. If the language were ever to be expanded or made more robust, it would perhaps 145 | be reasonable to rewrite the parser to make use of this model. 146 | 147 | \section{Type Inference} 148 | microML uses an implementation of 149 | \textit{algorithmW}\footnote{based on the following tutorial implementation 150 | \url{https://github.com/wh5a/Algorithm-W-Step-By-Step/blob/master/AlgorithmW.lhs}} for ML-style type inference. At present it is 151 | not possible to declare the types of functions, they can only be inferred. As this is primarily a 152 | teaching language with a very simple type system, this is not the drawback that it might otherwise 153 | be. 154 | 155 | A full description of Hindley-Milner type inference is beyond the scope of this report, however a 156 | brief overview of the concept is appropriate. 157 | 158 | At a trivial level, primitives have a predetermined type, so \textbf{(Lit (LInt 4))} has type 159 | \textbf{Number}, 160 | likewise \textbf{(Lit (LBoolean true))} has type \textbf{Bool}. 161 | 162 | At a slightly higher level, many operators only work on certain types, so the presence of these 163 | operators can help the inference system to resolve the constraints. For example 164 | 165 | (+) is defined to work only on objects of type Number. 166 | 167 | An expression of the type \textit{true + false} will fail with a \textit{unification error} as (+) 168 | is not a supported operator for this data type. 169 | 170 | Hindley-Milner is guaranteed to give the most general type signature possible. MicroML supports 171 | \textit{polymorphic} types. For example, the \textit{higher order} function 172 | `twice'\footnote{called `ap' in Haskell} has the form 173 | 174 | \begin{minted}{haskell} 175 | twice f x = f (f x) 176 | \end{minted} 177 | 178 | which has the type 179 | \begin{flalign*} 180 | & for\ all\ a. (a \rightarrow a) \rightarrow a \rightarrow a & 181 | \end{flalign*} 182 | 183 | The opening parentheses indicate that the first argument to \textit{twice} must be a function that 184 | takes one input of type `a' and maps it to something of the same type. The next `a' refers to x, and 185 | must be of a type accepted by the function f. The final result of the function must also be of the 186 | same type. It is not important what type `a' actually is, as long as these contraints hold. Herein 187 | lies the true power of type inference. 188 | 189 | At present, type inference in microML works for nearly all expression types in the grammar. Inference over 190 | lists is not yet working as it should: a request of 191 | 192 | \begin{minted}{haskell} 193 | head [1 to 10] 194 | \end{minted} 195 | 196 | returns a type of 197 | 198 | \begin{minted}{haskell} 199 | 1: [Number] 200 | \end{minted} 201 | 202 | which is incorrect. This is the only major area of type inference which is not working as expected. 203 | This problem is the next to be resolved. 204 | 205 | \section{REPL and JIT} 206 | It might reasonably be asked why a repl has been designed when it would seem extraneous to the goals 207 | of the project. The reasons for doing so are numerous: 208 | 209 | \begin{itemize} 210 | \item Easy parser testing: unfortunately Parsec does not have a testing framework to allow for 211 | the easy creation of a comprehensive test-suite\footnote{MegaParsec however does have this, 212 | which is a definite point its favour.} An interactive environment makes for a more 213 | `immediate' testing area. 214 | \item Type Inference testing: again, while no substitute for a formal test-suite, the repl has 215 | revealed, quickly and cheaply\footnote{The entire code numbers little more than 200 lines}, 216 | those parts which are working and those which are not. 217 | \item Applicability to C++ Compiler: the evaluation function\footnote{Eval.hs} might be regarded 218 | as the complement of the compiler. The evaluator takes the AST as produced by the parser and 219 | checked by the inference module and reduces it to a primitive form before pretty printing. 220 | The compiler takes the output from parsing and inference and translates it to another 221 | AST ready for pretty printing. Apart from the `eval' function itself, the process is 222 | remarkably similar. This has provided much needed practice with Haskell which otherwise would have 223 | been won more slowly with a labourious compilation cycle. 224 | \item Usability: a modern language ought to provide as many tools as possible for the programmer 225 | to make the task of programming as painless as it can be. A repl is a natural part of this. 226 | For students especially, an interactive environment is an excellent tool for learning about 227 | code without having the expense of compiling, flashing to the micro:bit and waiting for a 228 | possible error. 229 | \end{itemize} 230 | 231 | The JIT compiler is the result of an experiment with automatically producing C++ code for the 232 | micro:bit. LLVM\footnote{\url{llvm.org}} is able to produce C++ code from its \textit{ir}. Following an online 233 | tutorial\footnote{\url{https://github.com/sdiehl/kaleidoscope}} an attempt was made to output 234 | appropriate C++ for use with mBed. This was not ultimately successful\footnote{The 235 | resultant code is too reliant of using \textit{Clang} as its compiler, whereas the micro:bit 236 | needs a gcc extension. It would require heavy, intelligent, editing to make the code work.} but, 237 | time permitting, it might be a useful to integrate a working version of the jit into the repl environment, 238 | bringing microML slightly closer to the status of a real language. 239 | 240 | \section{Standard Library} 241 | Every language which aspires to be useful must have a standard library. As of the time of writing, 242 | microML has a number of small libraries which make the task of programming slightly simpler. These 243 | are general purpose libraries (written in microML) and are not micro:bit specific. The file 244 | `standard'\footnote{The standard library files can be found at \url{https://github.com/kellino/microML/tree/master/src/Libs}} 245 | features a number of higher-order functions which make manipulating lists easier. There 246 | is also a `combinators' library, for those interested in learning more about lambda-calculus, and 247 | the beginnings of a maths library. Obviously, once the compilation part of the project has been 248 | written, a number of micro:bit libraries will also have to be created, making the API available 249 | to the programmer. This ought to be a simple task of text substitution, where every occurrence of 250 | a particular function is linked to a version already `written out' in C++, with the only difficulty 251 | being the substitution of variables. 252 | 253 | \section{TODO} 254 | This progress report falls a little over a third into the allocted time for the project. Much has 255 | already been done, including a parser and type inference module which, while not perfect, perform 256 | their tasks efficiently and adequately. The only outstanding issue which has not yet been started is 257 | the compiler to C++. This is the next task, along with fixing the known errors in the type inference 258 | module, and a few minor irritations in the parser. The repl environment can be considered to be 259 | finished, as any changes to the parser will not effect the evaluation module. The jit is not a 260 | priority of any sort, but the code will be left in the github repository as a form of documentation. 261 | Time permitting, it can be returned to either later in the project or after submission. 262 | 263 | The standard libraries are, at present, embryonic. These will need to be extended. String 264 | manipulation is painful due to the treating of strings as immutable `literals'. To make working with 265 | strings a little more edifying, there also needs to be a string standard library.\ 266 | 267 | microML does not support forward declarations. Adding these would greatly enhance the usability of 268 | the language, as would nested `where'\footnote{A form of expression which allows forward declaration 269 | in a local scope.} 270 | expressions. Both of these would fail to pass type checking as it presently exists. However, again, 271 | these are not a priority. 272 | 273 | The language as currently constituted is Turing complete, and therefore can be used, albeit with 274 | difficulty, for any programming task. The remainder of project time will be given to constructing the 275 | compiler and improving the user experience with the language. Moreover a comprehensive test-suite 276 | needs to be written for those areas amenable to automatic testing, and manual tests for those which 277 | are not. 278 | 279 | \end{document} 280 | -------------------------------------------------------------------------------- /docs/repl.tex: -------------------------------------------------------------------------------- 1 | The following commands are available in the repl (Table~\ref{tabel:repl}): 2 | 3 | \begin{table}[ht] 4 | \begin{tabu}{l l r} 5 | Command & Arguments & Purpose \\ 6 | \hline \\ 7 | \textit{expr} & & Evaluate an expression \\ 8 | :t & function & Check the type of a function \\ 9 | :? :help & function / glossary & Read the help \\ 10 | :clear & & Clear the terminal \\ 11 | :using & lib name & Load a module from the standard library \\ 12 | :q :quit & & Exit microML \\ 13 | :load & filepath & Load a script into the repl \\ 14 | :browse & & See the functions in the environment \\ 15 | :pst & \textit{expr} & Pretty print parse tree to terminal \\ 16 | :pstText & \textit{expr} & Print text form of parse tree \\ 17 | :! & string & call the shell \\ 18 | \end{tabu} 19 | \caption{In-repl commands} 20 | \label{tabel:repl} 21 | \end{table} 22 | 23 | Interactions in the repl are \textbf{line-orientated}. Multiline input is not yet supported. 24 | 25 | The repl supports some configuration via \textit{microMLrc}, which is placed in the user's home 26 | directory upon installation. The default file is see in Figure~\ref{fig:config}. 27 | 28 | \begin{figure} 29 | \begin{minted}[breaklines=true]{bash} 30 | ## config file for microML 31 | 32 | ## simple ansi colour codes, see https://en.wikipedia.org/wiki/ANSI_escape_code for more details 33 | 34 | [colourscheme] 35 | bold = 1 36 | number = 31 37 | string = 32 38 | char = 34 39 | boolean = 33 40 | error = 31 41 | prompt = 33 42 | \end{minted} 43 | \caption{Configuration file for microML} 44 | \label{fig:config} 45 | \end{figure} 46 | -------------------------------------------------------------------------------- /docs/replCode.tex: -------------------------------------------------------------------------------- 1 | data IState = IState 2 | { typeEnv :: Env -- Type environment 3 | , termEnv :: TermEnv -- Value environment 4 | , helpEnv :: HelpEnv -- Help environment 5 | , configEnv :: ConfigEnv -- Config environment 6 | } 7 | 8 | initState :: IState 9 | initState = IState Env.microbit emptyTmenv HE.empty configEmpty 10 | 11 | type Repl a = HaskelineT (StateT IState IO) a 12 | 13 | hoistError :: (Show a1) => Either a1 a -> Repl a 14 | hoistError (Right val) = return val 15 | hoistError (Left err) = do 16 | liftIO $ print err 17 | abort 18 | 19 | evalDef :: TermEnv -> (String, Expr) -> TermEnv 20 | evalDef env (nm, ex) = termEnv' 21 | where (_, termEnv') = runEval env nm ex 22 | 23 | -- read the help info into a dictionary 24 | toHelpenv :: [HelpBlock] -> HelpEnv 25 | toHelpenv ls = HEnv $ Map.fromList ls 26 | 27 | -- | execution function while repl is running 28 | exec :: Bool -> L.Text -> Repl () 29 | exec update source = do 30 | st <- get 31 | 32 | mod' <- hoistError $ parseProgram "" source 33 | typeEnv' <- hoistError $ inferTop (typeEnv st) mod' 34 | 35 | let st' = st { termEnv = foldl' evalDef (termEnv st) mod' 36 | , typeEnv = typeEnv' `mappend` typeEnv st 37 | } 38 | 39 | when update (put st') 40 | 41 | case Prelude.lookup "it" mod' of 42 | Nothing -> return () 43 | Just ex -> do 44 | let (val, _) = runEval (termEnv st') "it" ex 45 | showOutput val st' 46 | 47 | -- | execution function for initial loading 48 | -- TODO: a lot of code repetition here, should be merged with exec 49 | exec' :: L.Text -> Repl () 50 | exec' source = do 51 | st <- get 52 | 53 | mod' <- hoistError $ parseProgram "" source 54 | typeEnv' <- hoistError $ inferTop (typeEnv st) mod' 55 | helpEnv' <- hoistError $ parseHelp "" source 56 | 57 | let st' = st { termEnv = foldl' evalDef (termEnv st) mod' 58 | , typeEnv = typeEnv' `mappend` typeEnv st 59 | , helpEnv = toHelpenv helpEnv' `mappend` helpEnv st 60 | } 61 | put st' 62 | 63 | showOutput :: Expr -> IState -> Repl () 64 | showOutput arg st = 65 | case Env.lookup "it" (typeEnv st) of 66 | Just val -> liftIO $ putStrLn $ ppsig (arg, val) (configEnv st) 67 | Nothing -> return () 68 | 69 | cmd :: String -> Repl () 70 | cmd source = exec True (L.pack source) 71 | 72 | -- | view the parse tree of an expression in the repl 73 | -- :pst command 74 | pst :: [String] -> Repl () 75 | pst expr = do 76 | st <- get 77 | tree <- hoistError $ parseProgram "" $ L.pack $ concatMap (++ " ") expr 78 | let tyEnv = inferTop (typeEnv st) tree 79 | case tyEnv of 80 | Left err -> liftIO . print $ err 81 | Right _ -> liftIO . showTree . head $ tree 82 | 83 | pstText :: [String] -> Repl () 84 | pstText expr = do 85 | st <- get 86 | tree <- hoistError $ parseProgram "" $ L.pack $ concatMap (++ " ") expr 87 | let tyEnv = inferTop (typeEnv st) tree 88 | case tyEnv of 89 | Left err -> liftIO . print $ err 90 | Right _ -> do -- liftIO . putStrLn . head $ tree 91 | liftIO . putStrLn $ "The parsetree of " ++ bold ++ (fst . head) tree ++ S.clear ++ " is: " 92 | liftIO . putStrLn $ show . snd . head $ tree 93 | 94 | -- :browse command 95 | browse :: [String] -> Repl () 96 | browse _ = do 97 | st <- get 98 | liftIO $ mapM_ putStrLn $ ppenv (typeEnv st) (configEnv st) 99 | 100 | help :: [String] -> Repl () 101 | help args = 102 | if null args 103 | then liftIO $ putStrLn "you haven't entered a function" 104 | else do st <- get 105 | let arg = unwords args 106 | case HE.lookup arg (helpEnv st) of 107 | Just val -> liftIO $ putStr $ "\n" ++ renderHelp val ++ "\n" 108 | Nothing -> liftIO $ putStrLn $ "there is no help available for " ++ arg ++ " (:" 109 | 110 | -- :using command 111 | -- this is only for files kept in the standard library 112 | using :: [String] -> Repl () 113 | using args = 114 | if null args 115 | then liftIO $ putStrLn "you must enter a library name!" 116 | else do dir <- liftIO getHomeDirectory 117 | let stdlib = dir ".microML/" 118 | exists <- liftIO $ doesDirectoryExist stdlib 119 | if exists 120 | then do 121 | let safe = fst (splitExtension $ unwords args) ++ ".mml" 122 | tr <- liftIO $ doesFileExist $ stdlib ++ safe 123 | if tr 124 | then do 125 | contents <- liftIO $ L.readFile $ stdlib ++ safe 126 | exec' contents 127 | else liftIO . putStrLn $ "the file " ++ unwords args ++ " does not exist" 128 | else error "Error: Unable to locate standard library in the home directory" 129 | 130 | -- :load command 131 | load :: [String] -> Repl () 132 | load args = 133 | if null args 134 | then liftIO $ putStrLn "you must enter a filename" 135 | else do 136 | tr <- liftIO $ doesFileExist (unwords args) 137 | if tr then do 138 | contents <- liftIO $ L.readFile (unwords args) 139 | exec True contents 140 | else liftIO $ putStrLn "the file does not exist" 141 | 142 | -- :type command 143 | typeof :: [String] -> Repl () 144 | typeof args = 145 | if null args 146 | then liftIO $ putStrLn "you must enter the name of a function" 147 | else do 148 | st <- get 149 | let arg = unwords args 150 | case Env.lookup arg (typeEnv st) of 151 | Just val -> liftIO $ putStrLn $ ppsig' (configEnv st) (arg, val) 152 | Nothing -> liftIO $ putStrLn $ "microML: " ++ show arg ++ " is not in scope" 153 | 154 | -- :quit command 155 | quit :: a -> Repl () 156 | quit _ = liftIO exitSuccess 157 | 158 | -- :clear 159 | clear :: a -> Repl () 160 | clear _ = liftIO $ S.callCommand "clear" 161 | 162 | -- :! access the shell, errors are wrapped in an IOException 163 | sh :: [String] -> Repl () 164 | sh arg = liftIO $ 165 | catch (S.callCommand (unwords arg)) 166 | (\e -> do let err = show (e :: IOException) 167 | hPutStr stderr ("Warning: Couldn't run " ++ unwords arg ++ " " ++ err ++ "\n") 168 | return ()) 169 | 170 | ----------------------- 171 | -- Interactive Shell -- 172 | ----------------------- 173 | 174 | -- Prefix tab completer 175 | defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] 176 | defaultMatcher = [ 177 | (":load" , fileCompleter) 178 | ] 179 | 180 | -- Default tab completer 181 | comp :: (Monad m, MonadState IState m) => WordCompleter m 182 | comp n = do 183 | let cmds = [":using", ":type", ":browse", ":quit", ":!", ":help", ":?", ":pst", ":clear", ":load", ":pstText"] 184 | Env.TypeEnv ctx <- gets typeEnv 185 | let defs = Map.keys ctx 186 | let builtins = reservedNames 187 | return $ filter (isPrefixOf n) (cmds ++ defs ++ builtins) 188 | 189 | options :: [(String, [String] -> Repl ())] 190 | options = [ 191 | ("using" , using) 192 | , ("browse" , browse) 193 | , ("quit" , quit) 194 | , ("type" , typeof) 195 | , ("!" , sh) 196 | , ("clear" , Repl.Repl.clear) 197 | , ("?" , help) 198 | , ("help" , help) -- alternative 199 | , ("pst" , pst) -- view parse tree of a given expression 200 | , ("pstText", pstText) 201 | , ("load" , load) 202 | ] 203 | 204 | ----------------- 205 | -- Entry Point -- 206 | ----------------- 207 | 208 | completer :: CompleterStyle (StateT IState IO) 209 | completer = Prefix (wordCompleter comp) defaultMatcher 210 | 211 | prompt :: String 212 | prompt = "microML ⊦ " ++ S.clear 213 | 214 | getBanner :: Repl () 215 | getBanner = do 216 | _ <- liftIO $ S.system "figlet -f $(ls /usr/share/figlet/fonts/*.flf |shuf -n1) \"microML\"\ 217 | \| cowsay -n -f $(ls /usr/share/cows | shuf -n1) | lolcat" 218 | return () 219 | 220 | standardBanner :: String 221 | standardBanner = not shown here 222 | 223 | -- | initialize the repl environment. Look for the dependencies for the fancy banner, and if not, 224 | -- use the boring standard one. 225 | ini :: Repl () 226 | ini = do 227 | fig <- liftIO $ findExecutable "figlet" 228 | cow <- liftIO $ findExecutable "cowsay" 229 | lol <- liftIO $ findExecutable "lolcat" 230 | if not (null fig) && not (null cow) && not (null lol) 231 | then do 232 | using ["standard"] 233 | liftIO $ putStrLn "\n\ESC[1mWelcome to microML\ESC[0m\t\t\t\ESC[33;1mversion 0.05\ESC[1;31m\n" 234 | getBanner 235 | liftIO $ putStrLn "\n\n" 236 | getConfig 237 | else do 238 | using ["standard"] 239 | liftIO $ putStrLn $ standardBanner ++ "\n\n" ++ bold ++ "Welcome to microML" ++ S.clear ++ "\n\n" 240 | getConfig 241 | 242 | -- | reads the config file (if it exists) and stores it in the global state 243 | -- also queries terminfo for max colours supported 244 | getConfig :: Repl () 245 | getConfig = do 246 | home <- liftIO getHomeDirectory 247 | let file = home ".microMLrc" 248 | exists <- liftIO $ doesFileExist file 249 | if exists 250 | then do 251 | st <- get 252 | conf <- liftIO $ DC.readfile DC.emptyCP file 253 | let cp = forceEither conf 254 | let config = forceEither $ DC.items cp "colourscheme" 255 | c <- liftIO maxColours 256 | let config' = config ++ [("term", show $ fromJust c)] 257 | let st' = st { configEnv = Map.fromList config' `mappend` configEnv st } 258 | put st' 259 | else error "Error: no configuration file found" 260 | 261 | -- | main function for the repl 262 | shell :: IO () 263 | shell = flip evalStateT initState $ evalRepl prompt cmd options completer ini 264 | -------------------------------------------------------------------------------- /docs/req.tex: -------------------------------------------------------------------------------- 1 | The functional requirements of microML are 2 | 3 | \newcolumntype{g}{>{\columncolor{light-gray}} l} 4 | \begin{table}[H] 5 | \begin{tabular}{g l c c} 6 | \rowcolor{light-gray} 7 | ID & Functional Requirements & Priority \\ 8 | 1 & Functional as simple calculator & Must \\ 9 | 2 & & & \\ 10 | 11 | \end{tabular} 12 | \end{table} 13 | -------------------------------------------------------------------------------- /docs/syntax.tex: -------------------------------------------------------------------------------- 1 | \subsection{Operators} 2 | 3 | MicroML has a full complement of operators. Table~\ref{table:operators} 4 | 5 | \begin{table} 6 | % \resizebox{\textwidth}{!} 7 | \begin{tabu}{l r} 8 | Operator & Action \\ 9 | \hline 10 | + & addition \\ 11 | - & subtraction \\ 12 | / & division (produces float) \\ 13 | * & multiplication \\ 14 | // & integer division (produces integer) \\ 15 | = & assignment \\ 16 | == & equality test \\ 17 | $/=$ & not equal \\ 18 | $<$ & less than \\ 19 | $<=$ & less than or equal \\ 20 | $>$ & greater than \\ 21 | $>=$ & greater than or equal \\ 22 | $:$ & cons \\ 23 | $++$ & joins lists or strings \\ 24 | \textasciicircum & exponential \\ 25 | \% & integer modulo \\ 26 | $>>$ & pipe operator \\ 27 | \hline 28 | true & logical true \\ 29 | false & logical false \\ 30 | or & logical or \\ 31 | and & logical and \\ 32 | not & logical not \\ 33 | xor & logical xor \\ 34 | \end{tabu} 35 | \caption{MicroML\@: arithmetical and logical operators} 36 | \label{table:operators} 37 | \end{table} 38 | 39 | \subsection{Declarations} 40 | Top-level declarations for variables and functions (simple and recursive) are prefaced with 41 | \textit{let}: 42 | 43 | \begin{minted}{sml} 44 | let x = 5 45 | let double x = x * 2 46 | \end{minted} 47 | 48 | \textit{Locally scoped declarations} are created with the let \dots in construction: 49 | 50 | \begin{minted}{sml} 51 | let addHidden y = 52 | let x = y * 2 - 3 53 | in x + y 54 | \end{minted} 55 | 56 | The if -- then -- else construction is an \textit{expression} in microML, so there must be an 57 | \textit{else}: 58 | 59 | \begin{minted}{sml} 60 | if x == 0 then true else false 61 | \end{minted} 62 | 63 | MicroML supports \textit{anonymous functions} with a syntax similar to Haskell: 64 | 65 | \begin{minted}{sml} 66 | let inc = \x -> x + 1 67 | \end{minted} 68 | 69 | These anonymous functions can also be used in pipes: 70 | 71 | \begin{minted}{sml} 72 | microML> (double 5) >> succ >> succ >> \x -> x^2 73 | microML> 144 : Number 74 | microML> (double 5) >> x -> x^2 >> succ >> succ 75 | microML> 102 : Number 76 | \end{minted} 77 | 78 | \subsection{Number Encodings} 79 | \label{encodings} 80 | MicroML supports encoding binary, octal and hex numbers: 81 | 82 | \begin{minted}{sml} 83 | microML> 2#110 84 | microML> 6 : Number 85 | microML> 8#777 86 | microML> 511 : Number 87 | microML> 16#2bbad21 88 | microML> 45853985 : Number 89 | microML> 8#342 + 2#1111 90 | microML> 241 : Number 91 | \end{minted} 92 | 93 | \subsection{List Syntax} 94 | Lists, being the fundamental data structure in microML, have a special syntax: 95 | 96 | \begin{minted}{sml} 97 | microML> [] (* the empty list *) 98 | microML> [1,2,3] (* list of Number *) 99 | \end{minted} 100 | 101 | Ranges (from small to large only) can be created with the `to' syntax: 102 | 103 | \begin{minted}{sml} 104 | microML> [1 to 5] 105 | microML> [1,2,3,4,5] : Number 106 | microML> [`a' to `e'] 107 | microML> [`a', `b', `c', `d', `e'] : Char 108 | \end{minted} 109 | 110 | \subsection{Tuples} 111 | Tuples are created with \{ and \} 112 | 113 | \begin{minted}{sml} 114 | microML> {1, 2} 115 | microML> {1, 2} : {Number, Number} 116 | \end{minted} 117 | 118 | \subsection{Indenting} 119 | MicroML does not (yet) have an indentation sensitive parser. Declarations are best written on one 120 | line in a file, though the parser is usually sophisticated enough to disambiguate multiline function 121 | declarations. 122 | -------------------------------------------------------------------------------- /docs/sysf.tex: -------------------------------------------------------------------------------- 1 | This treatment of System F is taken from~\cite{Pierce:2002:TPL:509043} 2 | 3 | \begin{minipage}{0.4\textwidth} 4 | \begin{tabu}{l l r} 5 | t ::= & & \\ 6 | & x & \textit{variable} \\ 7 | & $\lambda x:T.t$ & \textit{abstraction} \\ 8 | & t t & \textit{application} \\ 9 | & $\lambda X.t$ & \textit{type abstraction} \\ 10 | & t [T] & \textit{type application} \\ 11 | \end{tabu} 12 | \begin{tabu}{l l r} 13 | v ::= & & \\ 14 | & $\lambda x:T.t$ & \textit{abstraction value} \\ 15 | & $\lambda X.t$ & \textit{type abstraction value} \\ 16 | \end{tabu} 17 | \begin{tabu}{l l r} 18 | T ::= & & \\ 19 | & X & \textit{type variable} \\ 20 | & $T \rightarrow T $ & \textit{type of functions} \\ 21 | & $\forall X.T$ & \textit{universal type} \\ 22 | \end{tabu} 23 | \begin{tabu}{l l r} 24 | $\Gamma$ ::= & & \\ 25 | & $\varnothing$ & \textit{empty context} \\ 26 | & $\lambda x:T$ & \textit{type variable binding} \\ 27 | & $\Gamma ,T$ & \textit{application} \\ 28 | \end{tabu} 29 | \end{minipage} 30 | \hfill\vline\hfill 31 | \begin{minipage}{0.4\textwidth} 32 | \hspace{-10mm} 33 | \tabulinesep=2.2mm 34 | \begin{tabu}{l r} 35 | $\displaystyle \frac{t_1 \rightarrow t\prime_1}{t_1\:t_2 \rightarrow t\prime_1\:t_2}$ & (E-App1)\\ 36 | $\displaystyle \frac{t_2 \rightarrow t\prime_2}{v_1\:t_2 \rightarrow v_1\:t\prime_2}$ & 37 | (E-App2) \\ 38 | $\displaystyle (\lambda x:T_{11}.t_{12})v_2 \rightarrow [x \mapsto v_2] t_{12}$ & (E-AppAbs) 39 | \\ 40 | $\displaystyle \frac{t_1 \rightarrow t\prime_1}{t_1[T_2] \rightarrow t\prime_1[T_2]}$ & 41 | (E-TApp) \\ 42 | $\displaystyle (\lambda X.t_{12}[T_2]) \rightarrow [X \mapsto T_2] t_{12}$ & (E-TAppTAbs) \\ 43 | $\displaystyle \frac{x:T \in \Gamma}{\Gamma \vdash x:T}$ & (T-Var) \\ 44 | $\displaystyle \frac{\Gamma , x:T_1 \vdash t_2:T_2}{\Gamma \vdash \lambda x:T_1.t_2:T_1 \rightarrow T_2}$ & (T-Abs) \\ 45 | $\displaystyle \frac{\Gamma \vdash t_1:T_{11}\rightarrow T_{12}\;\Gamma \vdash 46 | t_1:T_{11}}{\Gamma \vdash t_1\:t_2:T_{12}}$ & (TApp) \\ 47 | $\displaystyle \frac{\Gamma , X \vdash t_2:T_2}{\Gamma \vdash \lambda X.t_2 : \forall X.T_2}$ & (T-TAbs) \\ 48 | $\displaystyle \frac{\Gamma \vdash t_1: \forall X.T_{12}}{\Gamma \vdash t_1 [T_2]:[X \mapsto 49 | T_2]T_{12}}$ & (T-TApp) \\ 50 | \end{tabu} 51 | \end{minipage} 52 | -------------------------------------------------------------------------------- /docs/texBib: -------------------------------------------------------------------------------- 1 | #!/usr/bin/bash 2 | 3 | pdflatex=$(which pdflatex) 4 | bibtex=$(which bibtex) 5 | file="$1" 6 | usingMinted=$(ag minted "$file".tex) 7 | 8 | ## the minted package needs pdflatex to be run with the shell-escape option 9 | ## so check for it in the file 10 | if [ -x "$pdflatex" ] && [ -x "$bibtex" ]; then 11 | if [ "$usingMinted" == "" ]; then 12 | echo "compiling $file" 13 | pdflatex "$file".tex 14 | bibtex "$file".aux 15 | pdflatex "$file".tex 16 | pdflatex "$file".tex 17 | else 18 | echo "minted detected, so using shell escape" 19 | echo "compiling $file" 20 | pdflatex -shell-escape "$file".tex 21 | bibtex "$file".aux 22 | pdflatex -shell-escape "$file".tex 23 | pdflatex -shell-escape "$file".tex 24 | fi 25 | fi 26 | -------------------------------------------------------------------------------- /docs/user.tex: -------------------------------------------------------------------------------- 1 | To build and install microML on a *\textit{Nix} system there is an installation script in the main directory 2 | of the repository. This does not need to be run with sudo permission. See 3 | Appendix~\ref{appendix:samples}. To build and install microML ensure that 4 | \textbf{stack}\footnote{\url{https://docs.haskellstack.org/en/stable/README/}} is installed. 5 | 6 | \textbf{MicroML has not been tested on Windows.} 7 | 8 | \begin{figure} 9 | \label{fig:help} 10 | \includegraphics[width=\textwidth]{images/help.jpg} 11 | {\caption{MicroML command line help}} 12 | \end{figure} 13 | 14 | \begin{itemize} 15 | \item Download the repository from Git \url{https://github.com/kellino/microML} 16 | \item Unzip the repository and cd into the directory. 17 | \item run installMicroML 18 | \end{itemize} 19 | 20 | Assuming the build has been successful, typing `microML --help' into the terminal shows the various options. See Figure~\ref{fig:help}. 21 | 22 | 23 | -------------------------------------------------------------------------------- /installMicroML: -------------------------------------------------------------------------------- 1 | #!/usr/bin/bash 2 | 3 | ## only tested on linux, but it should probably work on mac as well. Not a chance of windows unless 4 | ## you're using cygwin, with which I have no experience. 5 | ## doesn't check for clobbering, just reinstalls everything regardless 6 | 7 | join_by() { local IFS="$1"; shift; echo "$*"; } 8 | 9 | ## check for this software. Only stack is essential 10 | stack=$(which stack 2>/dev/null) 11 | fig=$(which figlet 2>/dev/null) 12 | cow=$(which cowsay 2>/dev/null) 13 | lol=$(which lolcat 2>/dev/null) 14 | dot=$(which dot 2>/dev/null) 15 | cl=$(which clang-format 2>/dev/null) 16 | 17 | if [ ! -x "$fig" ]; then 18 | progs=("${progs[@]}" "figlet ") 19 | fi 20 | 21 | if [ ! -x "$cow" ]; then 22 | progs=("${progs[@]}" " cowsay ") 23 | fi 24 | 25 | if [ ! -x "$lol" ]; then 26 | progs=("${progs[@]}" " lolcat") 27 | fi 28 | 29 | if [ -x "$stack" ]; then 30 | printf "\e[1mstack found\e[0m\n" 31 | printf "\e[1mrunning tests and building\e[0m\n" 32 | stack test 33 | rc=$? 34 | if [ "$rc" != 0 ]; then 35 | printf "\n\e[31mCould not pass all tests. The build has failed\e[0m\n" 36 | exit "$rc" 37 | fi 38 | printf "\e[1minstalling in %s/.local/bin/\n" "$HOME" 39 | stack install 40 | rc=$? 41 | if [ "$rc" != 0 ]; then 42 | printf "\nCould not install the executable into %s/.local/bin. 43 | \ Please copy it manually into your path\n" "$HOME" 44 | exit "$rc" 45 | fi 46 | printf "\n\e[1mcopying standard libraries to home directory\e[0m\n" 47 | 48 | ## delete old standard libs if they are found 49 | if [ -x "$HOME"/.microML ]; then 50 | printf "\n\e[1mremoving old standard library\e[0m\n" 51 | rm -rf "$HOME"/.microML 52 | fi 53 | printf "\n\e[1minstalling standard library\e[0m\n" 54 | 55 | cp -vr src/Libs "$HOME" 56 | mv "$HOME/Libs" "$HOME/.microML" 57 | printf "\n\e[1mcopying default .microMLrc to home directory\e[0m\n" 58 | 59 | cp -v utils/microMLrc "$HOME"/.microMLrc 60 | printf "\n\e[1mfinished!\e[0m\n" 61 | 62 | if [ -n "$progs" ]; then 63 | len=${#progs[@]} 64 | if [ "$len" -eq 1 ]; then 65 | str="${progs[*]}" 66 | elif [ "$len" -eq 2 ]; then 67 | str=$(join_by $"&" "${progs[@]}") 68 | else 69 | str=$("figlet, cowsay and lolcat") 70 | fi 71 | printf "\e[1mYou can have a more interesting repl if you also install %s\e[0m\n" "$str" 72 | fi 73 | 74 | if [ ! -x "$dot" ]; then 75 | printf "\e[1mIf you install \e[32mdot\e[0;1m then you can make callgraphs of your programs.\e[0m\n" 76 | fi 77 | 78 | if [ ! -x "$cl" ]; then 79 | printf "\e[1mIf you install \e[32mclang-format\e[0;1m then you can format your C++ code.\e[0m\n" 80 | fi 81 | else 82 | printf "\e[31mCould not find stack in your system path. Please install it using your package 83 | manager or go to \e[0;1mhttps://docs.haskellstack.org/en/stable/README/\e[0m\n" 84 | fi 85 | -------------------------------------------------------------------------------- /microML.cabal: -------------------------------------------------------------------------------- 1 | Name: microML 2 | Version: 0.0.5 3 | Synopsis: Functional Programming for BBC micro:bit 4 | Description: A simple functional programming language with a repl and a compiler to micro:bit c++ 5 | Author: David Kelly 6 | Maintainer: dkellino@gmail.com 7 | 8 | Category: Compiler 9 | 10 | Build-type: Simple 11 | Cabal-version: >=1.6 12 | 13 | test-suite microMLTest 14 | hs-source-dirs: test, src 15 | main-is: TestMain.hs 16 | type: exitcode-stdio-1.0 17 | ghc-options: -Wall -threaded 18 | build-depends: base, 19 | hspec 20 | 21 | executable microML 22 | hs-source-dirs: src 23 | Main-is: Main.hs 24 | 25 | Other-modules: Compiler.CallGraph, 26 | Compiler.CodeGen, 27 | Compiler.Failure, 28 | Compiler.MicroBitHeader, 29 | Compiler.PrettyCPP, 30 | MicroML.Config, 31 | MicroML.Lexer, 32 | MicroML.ListPrimitives, 33 | MicroML.MathsPrimitives, 34 | MicroML.Parser, 35 | MicroML.Syntax, 36 | MicroML.Typing.Env, 37 | MicroML.Typing.Infer, 38 | MicroML.Typing.Substitutable, 39 | MicroML.Typing.Type, 40 | MicroML.Typing.TypeError, 41 | Repl.Eval, 42 | Repl.Help, 43 | Repl.HelpEnv, 44 | Repl.Pretty, 45 | Repl.Repl, 46 | Repl.ParseTree 47 | 48 | -- Packages needed in order to build this package. 49 | Build-depends: base, 50 | parsec, 51 | repline, 52 | cmdargs, 53 | filepath, 54 | either, 55 | process, 56 | random, 57 | directory, 58 | mtl, 59 | text, 60 | pretty, 61 | containers, 62 | transformers, 63 | pretty-tree, 64 | MissingH, 65 | ConfigFile, 66 | split, 67 | terminfo-hs 68 | 69 | ghc-options: -Wall -O2 -threaded -fwarn-tabs -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-incomplete-patterns -fno-warn-unused-binds 70 | -------------------------------------------------------------------------------- /src/Compiler/CallGraph.hs: -------------------------------------------------------------------------------- 1 | module Compiler.CallGraph where 2 | 3 | import Data.List (nub, nubBy, sort, (\\)) 4 | import Data.Graph 5 | import Data.Function (on) 6 | import Data.Maybe (fromJust) 7 | 8 | import System.IO 9 | import System.Process 10 | import System.Directory 11 | import System.FilePath 12 | import Control.Exception (catch, IOException) 13 | 14 | import MicroML.Syntax 15 | 16 | ---------------- 17 | -- DUPLICATES -- 18 | ---------------- 19 | 20 | -- | if there are any duplicate definitions then abandon compilation. The line numbering function 21 | -- is very crude and not fit for purpose. It assumes each function only occupies one line and that 22 | -- there are no comments! 23 | 24 | -- | search the program for duplicate definitions and, if found, throw an error. Possibly a little 25 | -- bit too strict and rigid, but good for catching silly student errors. 26 | checkForDuplicates :: [(String, Expr)] -> [(String, Expr)] 27 | checkForDuplicates code 28 | | length code == length nubbed = code 29 | | otherwise = error $ red ++ "Error" ++ clear ++ ": duplicate definition of function " ++ getFuncName (length nubbed) code ++ 30 | " found at line " ++ "\ESC[1m" ++ show (length nubbed) ++ "\ESC[0m. Aborting." 31 | where nubbed = nubBy ((==) `on` fst . snd) numbered 32 | numbered :: [(Int, (String, Expr))] 33 | numbered = zip [1..] code 34 | 35 | getFuncName :: Int -> [(String, Expr)] -> String 36 | getFuncName n code = "\ESC[1m" ++ (fst . head . drop (n-1)) code ++ "\ESC[0m" 37 | 38 | ---------------------- 39 | -- UNREACHABLE CODE -- 40 | ---------------------- 41 | 42 | -- | is there a main? If not, throw an error straightaway and don't do any more work 43 | doesMainExist :: [(String, Expr)] -> Either String [(String, Expr)] 44 | doesMainExist code = if "main" `elem` map fst code then Right code else Left "no main" 45 | 46 | -- | rearrange program so main function is first in list 47 | putMainFirst :: [(String, Expr)] -> [(String, Expr)] 48 | putMainFirst code = dropWhile notMain code ++ takeWhile notMain code 49 | where notMain (x,_) = x /= "main" 50 | 51 | getRHSVars :: (String, Expr) -> (String, [String]) 52 | getRHSVars (nm, xs) = (nm, nub . extract . words . stripQuotes . stripParens . show $ xs) 53 | where stripParens = filter (\x -> x /= '(' && x /= ')') 54 | stripQuotes = filter (/= '\"') 55 | extract = go [] 56 | where go acc [] = acc 57 | go acc [_] = acc 58 | go acc (x:y:ys) 59 | | x == "Var" = go (y:acc) ys 60 | | otherwise = go acc (y:ys) 61 | 62 | -- | extract the names of toplevel functions definitions 63 | getTopLevel :: [(String, Expr)] -> [String] 64 | getTopLevel = foldr (\(x, _) a -> x : a) [] 65 | 66 | isCalled :: [(String, Expr)] -> [(String, [String])] 67 | isCalled code = map isCalled' code 68 | where isCalled' ex@(x,_) = (x, filter (`elem` tops) $ snd . getRHSVars $ ex) 69 | tops = getTopLevel code 70 | 71 | getOrderedNodes :: [(String, Expr)] -> [(String, [String])] 72 | getOrderedNodes code = 73 | case doesMainExist code of 74 | Right _ -> isCalled (putMainFirst code) 75 | Left _ -> error $ redError ++ "no main function found" 76 | 77 | -- convert program to DAG 78 | buildGraph :: [(String, Expr)] -> Graph 79 | buildGraph code = buildG (1, length code) $ concatMap (\(x, xs) -> zip (repeat x) xs) $ call mainFirst table 80 | where table = zip (getTopLevel mainFirst) [1..] 81 | mainFirst = putMainFirst code 82 | call c t = map (\(x, xs) -> (tLookup x t, map (`tLookup` t) xs)) (getOrderedNodes c) 83 | tLookup x' t' = fromJust $ Prelude.lookup x' t' 84 | 85 | -- | super simple directed graph in graphviz dot format 86 | formatDot :: [(String, Expr)] -> String 87 | formatDot cd = "digraph G {\n" ++ concat body ++ "}" 88 | where body = map (\x -> show (fst x) ++ " -> " ++ show (snd x) ++ ";\n") 89 | $ concatMap (\(y, ys) -> zip (repeat y) ys) $ getOrderedNodes cd 90 | 91 | -- | assumes write permission for the tmp directory. This is not a portable solution. 92 | writeDot :: String -> IO () 93 | writeDot = writeFile "/tmp/callgraph.dot" 94 | 95 | generatePng :: IO () 96 | generatePng = do 97 | dot <- findExecutable "dot" 98 | case dot of 99 | Nothing -> error "graphviz is not available on this system" 100 | Just _ -> do 101 | dir <- getCurrentDirectory 102 | let dest = dir "callgraph.png" 103 | catch (callCommand ("dot -Tpng " ++ "/tmp/callgraph.dot" ++ "> " ++ dest)) 104 | (\e -> do let err = show (e :: IOException) 105 | hPutStr stderr $ red ++ "Warning: " ++ clear ++ 106 | " Couldn't run \"dot\"\n." ++ err ++ 107 | "\nAbandoning graph compilation. Sorry :(" 108 | return ()) 109 | 110 | drawGraph :: [(String, Expr)] -> IO () 111 | drawGraph cd = do 112 | let graph = formatDot cd 113 | writeDot graph 114 | generatePng 115 | 116 | -- | the main function for the module 117 | reachableFromMain :: [(String, Expr)] -> [(String, Expr)] 118 | reachableFromMain cd = 119 | let reach = sort $ reachable (buildGraph cd) 1 120 | all' = [1..(length cd)] 121 | in if reach /= all' 122 | then error $ Compiler.CallGraph.tellError (map fst (getOrderedNodes cd)) (all' \\ reach) 123 | else cd 124 | 125 | ----------- 126 | -- ERROR -- 127 | ----------- 128 | 129 | -- report any errors during code generation 130 | tellError :: [String] -> [Int] -> String 131 | tellError nodes unreachable = 132 | let funcs = map (\x -> nodes !! (x-1)) unreachable 133 | in if length funcs == 1 134 | then redError ++ "The function " ++ bold ++ head funcs ++ clear ++ " is unreachable from main, so compilation is being abandoned.\n" ++ graphGen 135 | else redError ++ "The functions " ++ ppr funcs ++ " are unreachable from main, so compilation is being abandoned\n" ++ graphGen 136 | where ppr funcs' 137 | | length funcs' == 2 = bold ++ head funcs' ++ clear ++ " and " ++ bold ++ last funcs' ++ clear 138 | | otherwise = bold ++ head funcs' ++ clear ++ ", " ++ ppr funcs' 139 | graphGen = "Try running microML with the -g flag to see a png of the program graph, e.g microML - g myfile.mml" 140 | 141 | redError :: String 142 | redError = red ++ "Error: " ++ clear 143 | -------------------------------------------------------------------------------- /src/Compiler/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Compiler.CodeGen where 5 | 6 | import MicroML.Syntax 7 | import MicroML.Parser 8 | import Compiler.MicroBitHeader 9 | import Compiler.CallGraph 10 | import Compiler.Failure 11 | import qualified Compiler.Failure as F 12 | import Compiler.PrettyCPP 13 | import MicroML.Typing.Infer 14 | import MicroML.Typing.Env 15 | import qualified MicroML.Typing.Env as Env 16 | import Repl.Pretty() 17 | 18 | import qualified Data.Text.Lazy as L 19 | import qualified Data.Map as Map 20 | import Data.Char (toLower) 21 | 22 | import Text.PrettyPrint hiding (equals) 23 | 24 | import System.FilePath 25 | 26 | import Control.Monad.RWS hiding ((<>)) 27 | import Control.Monad.Except 28 | 29 | --------------- 30 | -- DATATYPES -- 31 | --------------- 32 | 33 | type Compiler a = (RWST CodeState [Doc] CompilerState (Except Failure) a) 34 | 35 | data CompilerState = CompilerState { count :: Int } 36 | 37 | initCompiler :: CompilerState 38 | initCompiler = CompilerState { count = 0 } 39 | 40 | type UserCode = Map.Map String Expr 41 | 42 | data CodeState = CodeState 43 | { userCode :: UserCode 44 | , typeEnv :: Env } 45 | 46 | initState :: CodeState 47 | initState = CodeState Map.empty Env.empty 48 | 49 | ------------------------- 50 | -- CPP CODE GENERATION -- 51 | ------------------------- 52 | 53 | -- generate fresh names for unnamed bindings in microML (eg. when using the >> operator) 54 | fresh :: Compiler Doc 55 | fresh = do 56 | s <- get 57 | put s{ count = count s + 1 } 58 | return $ text (letters !! count s) 59 | where letters = [1..] >>= flip replicateM ['a' .. 'z'] 60 | 61 | -- | generate C++ for functions 62 | genTopLevel :: [(Name, Expr)] -> Compiler [Doc] 63 | genTopLevel = mapM gtl 64 | where gtl :: (String, Expr) -> Compiler Doc 65 | gtl ("main", expr) = generateMain expr 66 | gtl (nm, expr) = generateFunc nm expr 67 | 68 | -- | handle the main function separately, as the return type is already known 69 | generateMain :: Expr -> Compiler Doc 70 | generateMain ex = do 71 | ex' <- genBody ex 72 | return $ "int main()" <> bracesNewLine (bitInit <> ex' <> fiber) 73 | 74 | generateFunc :: Name -> Expr -> Compiler Doc 75 | generateFunc nm ex = do 76 | ex' <- genBody ex 77 | return $ funcType <> nm' <> "()" <> bracesNewLine ("return " <> ex' <> ";\n") 78 | where nm' = text nm 79 | 80 | genIf :: Expr -> Compiler Doc 81 | genIf (If cond tr fls) = do 82 | cond' <- genBody cond 83 | tr' <- genBody tr 84 | fls' <- genBody fls 85 | return $ "if" <> parens cond' <> bracesNewLine tr' <> "else " <> fls' 86 | 87 | -- | placeholder !!! 88 | funcType :: Doc 89 | funcType = "ManagedString " 90 | 91 | genBody :: Expr -> Compiler Doc 92 | genBody ex = 93 | case ex of 94 | (Lit (LInt n)) -> return $ integer n 95 | (Lit (LDouble d)) -> return $ double d 96 | (Lit (LChar c)) -> return $ quotes $ char c 97 | (Lit (LString x)) -> return $ doubleQuotes $ text x 98 | (Lit (LBoolean x)) -> return $ text . map toLower . show $ x 99 | Lam _ _ -> failGen "" "not written yet" 100 | Var x -> 101 | case Map.lookup x microBitAPI of 102 | Nothing -> return $ text x 103 | Just r -> return r 104 | Let nm e1 e2 -> do 105 | ret <- getType e1 106 | e1' <- genBody e1 107 | e2' <- genBody e2 108 | return $ ret <> text nm <> " = " <> e1' <> semiWithNewLine <> e2' 109 | ifstat@If{} -> genIf ifstat 110 | App x xs -> do 111 | x' <- genBody x 112 | xs' <- genBody xs 113 | return $ x' <> parensWithSemi xs' 114 | BinOp op e1 e2 -> do 115 | e1' <- genBody e1 116 | e2' <- genBody e2 117 | case op of 118 | OpPipe -> pipeFuncs e1 e2 119 | _ -> return $ e1' <> ppr op <> e2' 120 | _ -> failGen (showText ex) ": this operation is presently unsupported" 121 | 122 | getType :: Expr -> Compiler Doc 123 | getType (Lit (LInt _)) = return $ "int" <> space 124 | getType (Lit (LDouble _)) = return $ "double" <> space 125 | getType (Lit (LString _)) = return $ "ManagedString" <> space 126 | getType (Lit (LChar _)) = return $ "char" <> space 127 | getType (Lit (LBoolean _)) = return $ "bool" <> space 128 | getType x = failGen (showText x) ": unable to ascertain type of this expression" 129 | 130 | pipeFuncs e1 e2 = do 131 | b1 <- genBody e1 132 | nm <- fresh 133 | b2 <- genBody (App e2 (Var $ render nm)) 134 | return $ "ManagedString " <> nm <> " = " <> b1 <> "();\n" <> b2 135 | 136 | hoistError :: Show a => Either a [(String, Expr)] -> [(String, Expr)] 137 | hoistError (Right val) = val 138 | hoistError (Left err) = error $ "\ESC[31;1mParse Error\ESC[0m: " ++ show err 139 | 140 | -- | check if the output file has an extension, strip it if present and add .cpp. Perhaps redundant, 141 | -- but safe. 142 | validateExtension :: String -> String 143 | validateExtension fl -- = if (snd . splitExtension) fl == ".cpp" then fl else (fst . splitExtension $ fl) ++ ".cpp" 144 | | extension == ".cpp" = fl 145 | | extension == "" = fl ++ ".cpp" 146 | | otherwise = error $ red ++ "File Extension Error: " ++ clear ++ extension ++ " is not a valid filetype for compiled microML.\n" 147 | ++ "Please try either .cpp or don't add an extension" 148 | where extension = snd . splitExtension $ fl 149 | 150 | writeToFile :: L.Text -> [Doc] -> IO () 151 | writeToFile dest code = do 152 | let cFile = validateExtension $ L.unpack dest 153 | let code' = foldr (<>) "" code 154 | writeFile cFile $ render (microBitIncludes <> code') 155 | -- if clang-format exists, then use it to clean up the formatting. 156 | formatPrintedFile cFile 157 | 158 | -- is the code complete and without repetitions? 159 | checkIntegrity :: [(Name, Expr)] -> [(Name, Expr)] 160 | checkIntegrity = reachableFromMain . checkForDuplicates 161 | 162 | codegen :: [(Name, Expr)] -> Compiler [Doc] 163 | codegen = genTopLevel . checkIntegrity 164 | 165 | runCompiler :: CodeState -> Compiler a -> Either Failure (a, [Doc]) 166 | runCompiler env m = runExcept $ evalRWST m env initCompiler 167 | 168 | -- | main compilation function 169 | compile :: L.Text -> L.Text -> String -> IO () 170 | compile source dest filename = do 171 | let res = hoistError $ parseProgram filename source 172 | let code = checkForDuplicates res 173 | case runCompiler initState $ codegen code of 174 | Left e -> print $ F.tellError e 175 | Right r -> writeToFile dest $ fst r 176 | -------------------------------------------------------------------------------- /src/Compiler/Failure.hs: -------------------------------------------------------------------------------- 1 | -- | Custom Error monad for the compiler 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | 6 | module Compiler.Failure where 7 | 8 | import Control.Monad.Except 9 | import Text.PrettyPrint 10 | 11 | data Stage = Parser | TypeCheck | CodeGen 12 | 13 | type Loc = Doc 14 | type Info = Doc 15 | 16 | data Failure = Failure 17 | { state :: Stage 18 | , location :: Loc 19 | , summary :: Info } 20 | 21 | tellError :: Failure -> Doc 22 | tellError Failure{..} = 23 | "Error: failure while " <> stateS <> " " <> location <> " " <> summary 24 | where stateS = case state of 25 | Parser -> "parsing" 26 | TypeCheck -> "typechecking" 27 | CodeGen -> "generating C code" 28 | 29 | failGen :: MonadError Failure m => Loc -> Info -> m a 30 | failGen loc info = throwError $ Failure CodeGen loc info 31 | -------------------------------------------------------------------------------- /src/Compiler/MicroBitHeader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Compiler.MicroBitHeader where 4 | 5 | import Text.PrettyPrint 6 | import qualified Data.Map as Map 7 | 8 | -- | this needs to be vastly extended to cope with the entire API. TODO 9 | -- this covers the basic display module only at the moment 10 | microBitAPI :: Map.Map String Doc 11 | microBitAPI = Map.fromList [ 12 | ("scroll", "uBit.display.scroll") 13 | , ("print", "uBit.display.print" ) 14 | , ("animate", "uBit.display.animate") 15 | , ("setBrightness", "uBit.display.setBrightness") 16 | , ("rotateTo", "uBit.display.rotateTo") 17 | ] 18 | 19 | microBitIncludes :: Doc 20 | microBitIncludes = "#include \"MicroBit.h\"\n\nMicroBit uBit;\n" 21 | 22 | bitInit :: Doc 23 | bitInit = "ubit.init();\n" 24 | 25 | fiber :: Doc 26 | fiber = "fiber_release();\n" 27 | -------------------------------------------------------------------------------- /src/Compiler/PrettyCPP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Compiler.PrettyCPP where 4 | 5 | import MicroML.Syntax 6 | import Text.PrettyPrint 7 | 8 | import System.Directory 9 | import System.Process 10 | import System.FilePath 11 | import System.IO 12 | import Control.Exception (catch, IOException) 13 | 14 | 15 | -- use clang-format, if installed, to render nice cpp, otherwise leave it ugly 16 | formatPrintedFile :: String -> IO () 17 | formatPrintedFile fl = do 18 | clang <- findExecutable "clang-format" 19 | case clang of 20 | Nothing -> putStr "" 21 | Just _ -> do 22 | catch (callCommand $ "clang-format " ++ fl ++ "> " ++ fl') 23 | (\e -> do let err = show (e :: IOException) 24 | hPutStr stderr ("Clang-format was unable to reformat" ++ fl ++ "\n" ++ err ++ "\n") 25 | return ()) 26 | renameFile fl' fl 27 | where fl' = fst (splitExtension fl) ++ "F" ++ ".cpp" 28 | 29 | showText :: Show a => a -> Doc 30 | showText = text . show 31 | 32 | semiWithNewLine :: Doc 33 | semiWithNewLine = semi <> "\n" 34 | 35 | parensWithSemi :: Doc -> Doc 36 | parensWithSemi d = parens d <> semi <> "\n" 37 | 38 | bracesNewLine :: Doc -> Doc 39 | bracesNewLine d = braces ("\n\t" <> d) <> "\n" 40 | 41 | class Pretty p where 42 | ppr :: p -> Doc 43 | 44 | instance Pretty Binop where 45 | ppr OpAdd = " + " 46 | ppr OpSub = " - " 47 | ppr OpMul = " * " 48 | ppr OpDiv = " / " 49 | ppr OpIntDiv = " / " 50 | ppr OpMod = " % " 51 | ppr OpOr = " || " 52 | ppr OpAnd = " && " 53 | ppr OpNotEq = " != " 54 | ppr OpEq = " == " 55 | ppr OpExp = "^" 56 | ppr OpLe = " <= " 57 | ppr OpLt = " < " 58 | ppr OpGe = " >= " 59 | ppr OpGt = " > " 60 | ppr OpXor = undefined 61 | ppr OpAppend = " + " 62 | -------------------------------------------------------------------------------- /src/Jit/Codegen.hs: -------------------------------------------------------------------------------- 1 | -- | largely derived from a tutorial by Stephen Diehl http://www.stephendiehl.com/llvm/ 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | module Jit.Codegen where 6 | 7 | import qualified Data.Map as Map 8 | import Data.String 9 | import Data.List (sortBy) 10 | import Data.Function (on) 11 | import Control.Monad.State 12 | 13 | import LLVM.General.AST 14 | import LLVM.General.AST.Global 15 | import qualified LLVM.General.AST.Constant as C 16 | import qualified LLVM.General.AST.Attribute as A 17 | import qualified LLVM.General.AST as AST 18 | import qualified LLVM.General.AST.CallingConvention as CC 19 | import qualified LLVM.General.AST.FloatingPointPredicate as FP 20 | 21 | 22 | ---------------- 23 | -- DATA TYPES -- 24 | ---------------- 25 | 26 | double :: Type 27 | double = FloatingPointType 64 IEEE 28 | 29 | newtype Codegen a = Codegen { runCodegen :: State CodegenState a } 30 | deriving (Functor, Applicative, Monad, MonadState CodegenState) 31 | 32 | newtype LLVM a = LLVM { unLLVM :: State AST.Module a } 33 | deriving (Functor, Applicative, Monad, MonadState AST.Module) 34 | 35 | type SymbolTable = [(String, Operand)] 36 | type Names = Map.Map String Int 37 | 38 | data CodegenState = 39 | CodegenState { 40 | currentBlock :: Name 41 | , blocks :: Map.Map Name BlockState 42 | , symtab :: SymbolTable 43 | , blockCount :: Int 44 | , count :: Word 45 | , names :: Names 46 | } deriving Show 47 | 48 | data BlockState = 49 | BlockState { 50 | idx :: Int 51 | , stack :: [Named Instruction] 52 | , term :: Maybe (Named Terminator) 53 | } deriving Show 54 | 55 | runLLVM :: AST.Module -> LLVM a -> AST.Module 56 | runLLVM = flip (execState . unLLVM) 57 | 58 | emptyModule :: String -> AST.Module 59 | emptyModule label = defaultModule { moduleName = label } 60 | 61 | emptyBlock :: Int -> BlockState 62 | emptyBlock i = BlockState i [] Nothing 63 | 64 | addDefn :: Definition -> LLVM () 65 | addDefn d = do 66 | defs <- gets moduleDefinitions 67 | modify $ \s -> s { moduleDefinitions = defs ++ [d] } 68 | 69 | define :: Type -> String -> [(Type, Name)] -> [BasicBlock] -> LLVM () 70 | define retty label argtys body = addDefn $ 71 | GlobalDefinition $ functionDefaults { 72 | name = Name label 73 | , parameters = ([Parameter ty nm [] | (ty, nm) <- argtys], False) 74 | , returnType = retty 75 | , basicBlocks = body 76 | } 77 | 78 | entry :: Codegen Name 79 | entry = gets currentBlock 80 | 81 | addBlock :: String -> Codegen Name 82 | addBlock bname = do 83 | bls <- gets blocks 84 | ix <- gets blockCount 85 | nms <- gets names 86 | 87 | let new = emptyBlock ix 88 | (qname, supply) = uniqueName bname nms 89 | 90 | modify $ \s -> s { blocks = Map.insert (Name qname) new bls 91 | , blockCount = ix + 1 92 | , names = supply 93 | } 94 | return (Name qname) 95 | 96 | setBlock :: Name -> Codegen Name 97 | setBlock bname = do 98 | modify $ \s -> s { currentBlock = bname } 99 | return bname 100 | 101 | getBlock :: Codegen Name 102 | getBlock = gets currentBlock 103 | 104 | modifyBlock :: BlockState -> Codegen () 105 | modifyBlock new = do 106 | active <- gets currentBlock 107 | modify $ \s -> s { blocks = Map.insert active new (blocks s) } 108 | 109 | current :: Codegen BlockState 110 | current = do 111 | c <- gets currentBlock 112 | blks <- gets blocks 113 | case Map.lookup c blks of 114 | Just x -> return x 115 | Nothing -> error $ "No such block: " ++ show c 116 | 117 | ---------------------- 118 | -- HELPER FUNCTIONS -- 119 | ---------------------- 120 | 121 | fresh :: Codegen Word 122 | fresh = do 123 | i <- gets count 124 | modify $ \s -> s { count = 1 + i } 125 | return $ i + 1 126 | 127 | uniqueName :: String -> Names -> (String, Names) 128 | uniqueName nm ns = 129 | case Map.lookup nm ns of 130 | Nothing -> (nm, Map.insert nm 1 ns) 131 | Just ix -> (nm ++ show ix, Map.insert nm (ix+1) ns) 132 | 133 | instance IsString Name where 134 | fromString = Name . fromString 135 | 136 | local :: Name -> Operand 137 | local = LocalReference double 138 | 139 | externf :: Name -> Operand 140 | externf = ConstantOperand . C.GlobalReference double 141 | 142 | assign :: String -> Operand -> Codegen () 143 | assign var x = do 144 | lcls <- gets symtab 145 | modify $ \s -> s { symtab = (var, x) : lcls } 146 | 147 | getVar :: String -> Codegen Operand 148 | getVar var = do 149 | syms <- gets symtab 150 | case lookup var syms of 151 | Just x -> return x 152 | Nothing -> error $ "Local variable not in scope: " ++ show var 153 | 154 | instr :: Instruction -> Codegen Operand 155 | instr ins = do 156 | n <- fresh 157 | blk <- current 158 | let i = stack blk 159 | let ref = UnName n 160 | modifyBlock $ blk { stack = i ++ [ref := ins] } 161 | return $ local ref 162 | 163 | terminator :: Named Terminator -> Codegen (Named Terminator) 164 | terminator trm = do 165 | blk <- current 166 | modifyBlock $ blk { term = Just trm } 167 | return trm 168 | 169 | sortBlocks :: [(Name, BlockState)] -> [(Name, BlockState)] 170 | sortBlocks = sortBy (compare `on` (idx . snd)) 171 | 172 | createBlocks :: CodegenState -> [BasicBlock] 173 | createBlocks m = map makeBlock $ sortBlocks $ Map.toList (blocks m) 174 | 175 | makeBlock :: (Name, BlockState) -> BasicBlock 176 | makeBlock (l, BlockState _ s t) = BasicBlock l s (maketerm t) 177 | where 178 | maketerm (Just x) = x 179 | maketerm Nothing = error $ "Block has no terminator: " ++ show l 180 | 181 | ---------------- 182 | -- OPERATIONS -- 183 | ---------------- 184 | 185 | fadd :: Operand -> Operand -> Codegen Operand 186 | fadd a b = instr $ FAdd NoFastMathFlags a b [] 187 | 188 | fsub :: Operand -> Operand -> Codegen Operand 189 | fsub a b = instr $ FSub NoFastMathFlags a b [] 190 | 191 | fmul :: Operand -> Operand -> Codegen Operand 192 | fmul a b = instr $ FMul NoFastMathFlags a b [] 193 | 194 | fdiv :: Operand -> Operand -> Codegen Operand 195 | fdiv a b = instr $ FDiv NoFastMathFlags a b [] 196 | 197 | br :: Name -> Codegen (Named Terminator) 198 | br val = terminator $ Do $ Br val [] 199 | 200 | cbr :: Operand -> Name -> Name -> Codegen (Named Terminator) 201 | cbr cond tr fl = terminator $ Do $ CondBr cond tr fl [] 202 | 203 | ret :: Operand -> Codegen (Named Terminator) 204 | ret val = terminator $ Do $ Ret (Just val) [] 205 | 206 | call :: Operand -> [Operand] -> Codegen Operand 207 | call fn args = instr $ Call Nothing CC.C [] (Right fn) (toArgs args) [] [] 208 | 209 | toArgs :: [Operand] -> [(Operand, [A.ParameterAttribute])] 210 | toArgs = map (\x -> (x, [])) 211 | 212 | alloca :: Type -> Codegen Operand 213 | alloca ty = instr $ Alloca ty Nothing 0 [] 214 | 215 | store :: Operand -> Operand -> Codegen Operand 216 | store ptr val = instr $ Store False ptr val Nothing 0 [] 217 | 218 | load :: Operand -> Codegen Operand 219 | load ptr = instr $ Load False ptr Nothing 0 [] 220 | 221 | fcmp :: FP.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand 222 | fcmp cond a b = instr $ FCmp cond a b [] 223 | 224 | cons :: C.Constant -> Operand 225 | cons = ConstantOperand 226 | 227 | uitofp :: Type -> Operand -> Codegen Operand 228 | uitofp ty a = instr $ UIToFP a ty [] 229 | 230 | entryBlockName :: String 231 | entryBlockName = "entry" 232 | 233 | execCodegen :: Codegen a -> CodegenState 234 | execCodegen m = execState (runCodegen m) emptyCodegen 235 | 236 | emptyCodegen :: CodegenState 237 | emptyCodegen = CodegenState (Name entryBlockName) Map.empty [] 1 0 Map.empty 238 | -------------------------------------------------------------------------------- /src/Jit/Emit.hs: -------------------------------------------------------------------------------- 1 | module Jit.Emit where 2 | 3 | import qualified Data.Map as Map 4 | 5 | import LLVM.General.Module 6 | import LLVM.General.Context 7 | import qualified LLVM.General.AST as AST 8 | import qualified LLVM.General.AST.Constant as C 9 | import qualified LLVM.General.AST.Float as F 10 | import qualified LLVM.General.AST.FloatingPointPredicate as FP 11 | 12 | import Control.Monad (forM_) 13 | import Control.Monad.Except 14 | import MicroML.Syntax 15 | import Jit.Codegen 16 | 17 | codegenTop :: Expr -> LLVM () 18 | codegenTop (Lam name body) = 19 | define double name fnargs bls 20 | where 21 | fnargs = toSig body 22 | bls = createBlocks $ execCodegen $ do 23 | entry <- addBlock entryBlockName 24 | setBlock entry 25 | forM_ body $ \a -> do 26 | var <- alloca double 27 | store var (local (AST.Name a)) 28 | assign a var 29 | cgen body >>= ret 30 | codegenTop exp = 31 | define double "main" [] blks 32 | where 33 | blks = createBlocks $ execCodegen $ do 34 | entry <- addBlock entryBlockName 35 | setBlock entry 36 | cgen exp >>= ret 37 | 38 | toSig :: [String] -> [(AST.Type, AST.Name)] 39 | toSig = map (\x -> (double, AST.Name x)) 40 | 41 | cgen :: Expr -> Codegen AST.Operand 42 | cgen (Lit (LInt n)) = return $ cons $ C.Float (F.Double n) 43 | cgen (Lit (LDouble d)) = return $ cons $ C.Float (F.Double d) 44 | cgen (Var x) = getVar x >>= load 45 | cgen (Op op a b) = 46 | case Map.lookup op binops of 47 | Just f -> do 48 | ca <- cgen a 49 | cb <- cgen b 50 | f ca cb 51 | Nothing -> error "No such operator" 52 | 53 | 54 | binops = Map.fromList [ 55 | ("+", fadd) 56 | , ("-", fsub) 57 | , ("*", fmul) 58 | , ("/", fdiv) 59 | , ("<", lt) 60 | ] 61 | 62 | lt :: AST.Operand -> AST.Operand -> Codegen AST.Operand 63 | lt a b = do 64 | test <- fcmp 65 | uitofp double test 66 | 67 | liftError :: ExceptT String IO a -> IO a 68 | liftError = runExceptT >=> either fail return 69 | 70 | codegen :: AST.Module -> [Expr] -> IO AST.Module 71 | codegen mod fns = withContext $ \context -> 72 | liftError $ withModuleFromAST context newast $ \m -> do 73 | llstr <- moduleLLVMAssembly m 74 | putStrLn llstr 75 | return newast 76 | where 77 | modn = mapM codegenTop fns 78 | newast = runLLVM mod modn 79 | 80 | -------------------------------------------------------------------------------- /src/Libs/church.mml: -------------------------------------------------------------------------------- 1 | -- Church encoding and Peano numeral 2 | let tr x y = x; 3 | let fls x y = y; 4 | let zero f x = x; 5 | let one f x = f x; 6 | let two f x = f (f x); 7 | let three f x = f (f (f x)); 8 | let four f x = f (f (f (f x))); 9 | let five f x = f (f (f (f (f x)))); 10 | let six f x = f (f (f (f (f (f x))))); 11 | let seven f x = f (f (f (f (f (f (f x)))))); 12 | let eight f x = f (f (f (f (f (f (f (f x))))))); 13 | let nine f x = f (f (f (f (f (f (f (f (f x)))))))); 14 | let ten f x = f (f (f (f (f (f (f (f (f (f x))))))))); 15 | let isZero n = n (\x -> fls) tr; 16 | (* ==church numeral== *) 17 | -------------------------------------------------------------------------------- /src/Libs/combinators.mml: -------------------------------------------------------------------------------- 1 | -- true and false as λcalculus 2 | let tr x y = x 3 | let fls x y = y 4 | let not' p = p tr fls 5 | let and' p q = p q fls 6 | let or' p q = p tr q 7 | let cond p x y = p x y 8 | let xor' p q = p (q fls tr) q 9 | --SKI combinators 10 | let i x = x -- this is the same as id 11 | let k x y = x -- same as constant 12 | let s f g x = f x (g x) 13 | let mu f = f (mu f) 14 | let b x y z = x (y z) 15 | let c x y z = x z y 16 | let w x y = x y y 17 | (* == == *) 18 | -------------------------------------------------------------------------------- /src/Libs/glossary.mml: -------------------------------------------------------------------------------- 1 | -- GLOSSARY -- 2 | (* 3 | ==head== 4 | ***head*** 5 | ** head :: [a] -> a 6 | head takes the first element from a list 7 | #Example:# 8 | > head [1,2,3] 9 | > 1 : Number 10 | > head [] 11 | > head of an empty list **this is an error** 12 | *) 13 | -------------------------------------------------------------------------------- /src/Libs/maths.mml: -------------------------------------------------------------------------------- 1 | ---------------------------- 2 | -- MATHS STANDARD LIBRARY -- 3 | ---------------------------- 4 | -- constants 5 | (* 6 | ==pi== 7 | ***pi π*** 8 | the constant, π 9 | 3.14159265359 10 | *) 11 | let pi = 3.14159265359 12 | 13 | (* 14 | ==e== 15 | ***e*** 16 | euler's number 17 | 2.718281828459 18 | *) 19 | let e = 2.718281828459 20 | 21 | (* 22 | ==abs== 23 | ***abs*** 24 | ** abs :: Number -> Number ** 25 | gets the absolute value of a number: that is, its distance from zero. As a result, it is always 26 | positive 27 | #Example:# 28 | > abs 3 29 | > 3 : Number 30 | > abs (-3) ** note the use of the parentheses! ** 31 | > 3 : Number 32 | *) 33 | let abs x = if x > 0 then x else x * (-1) 34 | 35 | (* 36 | ==negate== 37 | ***negate*** 38 | ** negate :: Number -> Number ** 39 | turns a positive number negative, or a negative number positive 40 | *) 41 | let negate x = if x < 0 then abs x else x * -1 42 | 43 | (* 44 | ==max== 45 | ***max*** 46 | ** max :: Number -> Number -> Number ** 47 | *) 48 | let max a b = if (a + 0) < (b + 0) then b else a 49 | 50 | (* 51 | ==min== 52 | ***min*** 53 | ** min :: Number -> Number -> Number ** 54 | *) 55 | let min a b = if (a + 0) < (b + 0) then a else b 56 | (* 57 | ==intToFloat== 58 | ***intToFloat*** 59 | ** intToFloat :: Number -> Number ** 60 | *) 61 | let intToFloat x = x + 0.0 62 | 63 | (* 64 | ==reciprocal== 65 | ***reciprocal*** 66 | ** reciprocal :: Number -> Number ** 67 | *) 68 | let reciprocal x = 1 / x 69 | 70 | (* 71 | ==square== 72 | ***square*** 73 | ** square :: Number -> Number ** 74 | *) 75 | let square a = a * a 76 | 77 | (* 78 | ==sqrt== 79 | ***sqrt*** 80 | ** sqrt :: Number -> Number ** 81 | *) 82 | let sqrt x = x^0.5 83 | 84 | (* 85 | ==sum== 86 | ***sum*** 87 | ** sum :: [Number] -> Number ** 88 | *) 89 | let sum xs = foldr (\x y -> x + y) 0 xs 90 | 91 | (* 92 | ==product== 93 | ***product*** 94 | ** product :: [Number] -> Number ** 95 | *) 96 | let product xs = foldr (\x y -> x * y) 1 xs 97 | 98 | (* 99 | ==floor== 100 | ***floor*** 101 | ** floor :: Number -> Number ** 102 | *) 103 | let floor x = x // 1 104 | 105 | (* 106 | ==ceiling== 107 | ***ceiling*** 108 | ** ceiling :: Number -> Number ** 109 | *) 110 | let ceiling x = 1 + (floor x) 111 | 112 | (* 113 | ==floatToInt== 114 | ***floatToInt*** 115 | ** floatToInt :: Number -> Number ** 116 | *) 117 | let floatToInt x = floor x 118 | 119 | (* 120 | ==fib== 121 | ***fibonacci*** 122 | ** fib :: Number -> Number ** 123 | *) 124 | let fib n = if n < 2 then 1 else (fib (n-1)) + (fib (n-2)) 125 | 126 | (* 127 | ==gcd== 128 | ***greatest common divisor*** 129 | ** gcd :: Number -> Number -> Number ** 130 | finds the greatest common divisor of two numbers 131 | *) 132 | let gcd a b = if (a + 0) == b then a else if a < b then gcd b a else gcd b (a-b) 133 | 134 | (* 135 | ==factorial== 136 | ***factorial*** 137 | ** factorial :: Number -> Number ** 138 | finds the factorial (!) of a number 139 | #Example:# 140 | > factorial 5 ** 5! in maths notation ** 141 | > 120 : Number 142 | factorials grow really quickly... 143 | > factorial 10 144 | > 3628800 : Number 145 | *) 146 | let factorial n = product [1 to n]; 147 | 148 | ---------------- 149 | -- LOGARITHMS -- 150 | ---------------- 151 | 152 | (* 153 | ==ln== 154 | ***ln*** 155 | ** ln :: Number -> Number ** 156 | the natural log of a number 157 | *) 158 | let ln x = _log x 159 | 160 | (* 161 | ==log2== 162 | ***log2*** 163 | ** log2 :: Number -> Number ** 164 | the base 2 log of a number 165 | *) 166 | let log2 x = _log x / _log x 167 | 168 | (* 169 | ==log10== 170 | ***log10*** 171 | ** log10 :: Number -> Number ** 172 | the base 10 log of a number 173 | *) 174 | let log10 x = _log x / _log 10 175 | 176 | (* 177 | ==logBase== 178 | ***logBase*** 179 | ** logBase :: Number -> Number ** 180 | the log of a number at any base you like! 181 | *) 182 | let logBase x y = _log (y + 0) / _log (x + 0) 183 | 184 | ---------------------------- 185 | -- TRIGONOMETRY FUNCTIONS -- 186 | ---------------------------- 187 | 188 | (* 189 | ==radians== 190 | ***radians*** 191 | ** radians :: Number -> Number ** 192 | radians converts __degrees__ to __radians__ 193 | *) 194 | let radians x = (x / 180) * pi 195 | 196 | (* 197 | ==sin== 198 | ***sin*** 199 | ** sin :: Number -> Number ** 200 | finds the sine of an angle (using the Taylor series) 201 | *) 202 | let sin x = if x == 90 then 1 else if x == 180 then 0 else let y = radians x in y - (y^3 / 6) + (y^5 / 120) - (y^7 / 5070) + (y^9 / 362880) - (y^11 / 39916800) 203 | 204 | (* 205 | ==cos== 206 | ***cosine*** 207 | ** cos :: Number -> Number ** 208 | finds the cosine of an angle (using the Taylor series) 209 | *) 210 | let cos x = if x == 180 then (-1) else sin (90 - x) 211 | 212 | (* 213 | ==tan== 214 | ***tan*** 215 | ** tan :: Number -> Number ** 216 | tan of an angle 217 | *) 218 | let tan x = (sin x) / (cos x) 219 | 220 | (* 221 | ==arctan== 222 | ***arctan*** 223 | ** arctan :: Number -> Number ** 224 | the inverse of tan 225 | *) 226 | let arctan n = let x = abs n in let i = if x <= (2 - (sqrt 3)) then x else ((sqrt 3) * x - 1) / ((sqrt 3) + x) in let at = i - (i^3 / 3) + (i^5 / 5) - (i^7 / 7) in (pi / 6) + at >> \x -> x * (180 / pi) 227 | 228 | (* 229 | ==arcsin== 230 | ***arcsin*** 231 | ** arcsin :: Number -> Number ** 232 | the inverse of sin 233 | *) 234 | let arcsin x = arctan (x / (sqrt (1 - x^2))) 235 | 236 | (* 237 | ==arccos== 238 | ***arccos*** 239 | ** arccos :: Number -> Number ** 240 | tan of an angle 241 | *) 242 | let arccos x = arctan ((sqrt (1 - x^2)) / x) 243 | 244 | (* 245 | ==triangleNumbers== 246 | ***triangleNumbers*** 247 | ** triangleNumbers :: Number -> [Number] ** 248 | list of triangle numbers 249 | *) 250 | let triangleNumbers n = scanl1 (\x y -> x + y) [1 to (n+1)]; 251 | 252 | (* 253 | ==choose== 254 | ***choose*** 255 | ** choose :: Number -> Number -> Number ** 256 | n choose k 257 | *) 258 | let choose n k = (factorial n) / ((factorial k) * (factorial (n-k))) 259 | -------------------------------------------------------------------------------- /src/Libs/standard.mml: -------------------------------------------------------------------------------- 1 | (* ==unary== 2 | ***unary*** 3 | a **unary** function only takes **1** argument 4 | #Example:# 5 | > zero? 3 **zero? only takes one argument** 6 | > false : Boolean 7 | > zero? 3 4 **doesn't make any sense!** 8 | however 9 | > zero? (3 - 3) **this is ok** 10 | > true : Boolean 11 | *) 12 | 13 | (* 14 | ==binary== 15 | ***binary*** 16 | A **binary function** accepts only two arguments. A example would be __const__ 17 | #Example:# 18 | > const "hello" "there" 19 | > "hello" : String 20 | A **binary number** is a base 2 number composed only of 0s and 1s. In microML we 21 | enter them like this: 22 | #Example:# 23 | > 1001001 24 | > 73 : Number 25 | see __octal__ and __hex__ 26 | *) 27 | 28 | (* 29 | ==polymorphic== 30 | ***polymorphism*** 31 | a polymorphic function can take arguments of more than one type 32 | #Example:# 33 | > id :: a -> a 34 | > id 3 35 | > 3 36 | > id 'a' 37 | > a 38 | We do not need to write separate id functions for every possible type of input. Compare this with C 39 | where we would need a different function of the different inputs. 40 | *) 41 | 42 | (* 43 | ==boolean== 44 | ***boolean*** 45 | a true or false value 46 | *) 47 | (* 48 | ==hof== 49 | ***higher order function*** 50 | a higher order function is a function that does one (or both) of the two following things 51 | > takes one or more functions as arguments (c.f flip) 52 | > return a function as a result 53 | The second example needs a little more explanation... 54 | #Example:# 55 | > let twice f x = f (f x) **this is including in the standard library** 56 | > let add3 x = x + 3 57 | > let g = twice add3 **g is also a higher order function!** 58 | > g 59 | > <> : Number -> Number 60 | > g 7 61 | > 13 : Number 62 | *) 63 | 64 | (* 65 | ==id== 66 | ***id*** 67 | ** id :: a -> a ** 68 | id is a __unary__ function. It returns what was given to it without changes, throwing away extra arguments 69 | #Example:# 70 | > id 5 71 | > 5 : Number 72 | > id 'a' 73 | > a : Char 74 | *) 75 | let id x = x 76 | 77 | (* 78 | ==zero?== 79 | ***zero?*** 80 | ** zero? :: Number -> Boolean ** 81 | zero checks if a number or value is equal to 0 82 | #Example:# 83 | > let x = 1 84 | > zero? x 85 | > false : Boolean 86 | *) 87 | let zero? x = if x == 0 then true else false 88 | 89 | (* 90 | ==odd?== 91 | ***odd?*** 92 | ** odd? :: Number -> Boolean ** 93 | odd? checks if a number is odd, returning a __boolean__ value. 94 | #Example:# 95 | > odd? 5 96 | > true : Boolean 97 | > odd? 4 98 | > false : Boolean 99 | *) 100 | let odd? x = if x % 2 == 1 then true else false 101 | 102 | (* 103 | ==even?== 104 | ***even?*** 105 | ** even? :: Number -> Boolean ** 106 | even? checks if a number is even, returning a __boolean__ value. 107 | #Example:# 108 | > even? 4 109 | > true : Boolean 110 | > even? 5 111 | > false : Boolean 112 | *) 113 | let even? x = if x % 2 == 0 then true else false 114 | 115 | (* 116 | ==positive?== 117 | ***positive?*** 118 | ** positive? :: Number -> Boolean ** 119 | positive? checks if a number is greater than or equal to 0, returning a __boolean__ value. 120 | #Example:# 121 | > positive? 4 122 | > true : Boolean 123 | > positive? (-5) 124 | > false : Boolean 125 | *) 126 | let positive? x = if x >= 0 then true else false 127 | 128 | (* 129 | ==negative?== 130 | ***negative?*** 131 | ** negative? :: Number -> Boolean ** 132 | negative? checks if a number is less than 0, returning a __boolean__ value. 133 | #Example:# 134 | > negative? (-4) 135 | > true : Boolean 136 | > negative? 5 137 | > false : Boolean 138 | *) 139 | let negative? x = if x < 0 then true else false 140 | 141 | (* 142 | ==show== 143 | ***show*** 144 | ** show :: for all a. a -> String ** 145 | show takes a value and returns it as a string 146 | #Example:# 147 | > show 3 148 | > "3" : String 149 | > show 'a' 150 | > "a" : String 151 | *) 152 | let show x = _show x 153 | 154 | (* 155 | ==read== 156 | ***read*** 157 | ** read :: String -> Number ** 158 | read takes a string of a number and returns something of type number 159 | #Example:# 160 | > read "3" 161 | > 3 : Number 162 | > read "3.3" 163 | > 3.3 : Number 164 | *) 165 | let read x = _read x 166 | 167 | (* 168 | ==const== 169 | ***const*** 170 | ** const :: for all a b. a -> b -> a ** 171 | const return only the first of its two arguments, throwing the second away 172 | #Example:# 173 | > const 3 4 174 | > 3 : Number 175 | > const 'a' "hello" 176 | > 'a' : Char 177 | Note that const is __polymorphic__: it can take two arguments of any type, the same or different. 178 | *) 179 | let const x y = x 180 | 181 | (* 182 | ==succ== 183 | ***succ*** 184 | ** succ :: Number -> Number ** 185 | succ adds one to a number 186 | #Example:# 187 | > succ 3 188 | > 4 : Number 189 | *) 190 | let succ x = x + 1 191 | 192 | (* 193 | ==flip== 194 | ***flip*** 195 | ** flip :: for all a b c. (a -> b -> c) -> b -> a -> c ** 196 | flip is a __hof__ (higher order function). Its first argument is a function which takes two arguments. 197 | Flip changes the order of the aruments. 198 | #Example:# 199 | > let sub a b = a - b 200 | > sub 3 4 201 | > -1 : Number 202 | > flip sub 3 4 203 | > 1 : Number 204 | *) 205 | let flip f = \x y -> f y x 206 | 207 | (* 208 | ==twice== 209 | ***twice*** 210 | ** twice :: for all a. (a -> a) -> a -> a ** 211 | twice takes a function and a value and applies the function to it twice 212 | #Example:# 213 | > twice succ 4 214 | > 6 : Number 215 | Why 6? 216 | > succ 5 **the first time through the function** 217 | > 5 218 | > succ 5 **the second application of succ, this time with the new value** 219 | > 6 220 | *) 221 | let twice f x = f (f x) 222 | 223 | (* 224 | ==pipe== 225 | ***pipe*** 226 | ** pipe : for all a b. a -> (a -> b) -> b ** 227 | pipe takes a value and **pushes it through** a function (reading from left to right). 228 | #Example:# 229 | > pipe 5 succ 230 | > 6 : Number 231 | > pipe 5 (twice succ) 232 | > 7 : Number 233 | *) 234 | let pipe x f = f x 235 | 236 | (* 237 | ==compose== 238 | ***compose*** 239 | ** compose : for all a b c. (a -> b) -> (c -> a) -> c -> b ** 240 | compose takes two functions and a value, passing the value through both functions (reading from 241 | right to left). 242 | #Example:# 243 | > compose double succ 4 244 | > 10 : Number 245 | What has happened here? 246 | > succ 4 **succ is applied to the value 4** 247 | > 5 **the result is 5** 248 | > double 5 **5 is then passed to double** 249 | > 10 **and the result is 10** 250 | *) 251 | let compose f g x = f (g x) 252 | 253 | (* 254 | ==replicate== 255 | ***replicate*** 256 | ** replicate :: Number -> a -> [a] ** 257 | *) 258 | let replicate n x = if n == 1 then (x:[]) else x : (replicate (n-1) x) 259 | 260 | (* 261 | ==empty?== 262 | ***empty?*** 263 | ** empty? :: [a] -> Boolean ** 264 | A shortcut for **if xs == []**. Helpful when defining a __recursive__ function on a list. 265 | *) 266 | let empty? xs = if xs == [] then true else false 267 | 268 | (* 269 | ==length== 270 | ***length*** 271 | ** length :: [a] -> Number ** 272 | returns the length of a list 273 | #Example:# 274 | > length [1 to 5] 275 | > 5 : Number 276 | > length ['a', 'b', 'c'] 277 | > 3 : Number 278 | *) 279 | let length xs = if empty? xs then 0 else 1 + (length (tail xs)) 280 | 281 | (* 282 | ==drop== 283 | ***drop*** 284 | ** drop :: Number -> [a] -> [a] ** 285 | drops the specified number from the start of a list. The opposite of __take__ 286 | #Example:# 287 | > drop 2 [1 to 5] 288 | > [3,4,5] : [Number] 289 | *) 290 | let drop n xs = if zero? n then xs else if (length xs) < n then [] else (drop (n-1) (tail xs)) 291 | 292 | (* 293 | ==take== 294 | ***take*** 295 | ** take :: Number -> [a] -> [a] ** 296 | takes the specified number from the start of the list, dropping the rest 297 | #Example:# 298 | > take 2 [1 to 5] 299 | > [1,2] : Number 300 | *) 301 | let take n xs = if zero? n then [] else ((head xs) : (take (n-1) (tail xs))) 302 | 303 | (* 304 | ==dropEvery== 305 | ***dropEvery*** 306 | ** dropEvery :: Number -> [a] -> [a] ** 307 | drops every nth element from a list 308 | #Example:# 309 | > dropEvery 2 [1 to 10] ** drops every 2nd element from the list ** 310 | > [1, 3, 5, 7, 9] : [Number] 311 | *) 312 | let dropEvery n xs = if xs == [] then [] else (head xs) : (dropEvery n (drop n xs)) 313 | 314 | (* 315 | ==foldr== 316 | ***foldr*** 317 | ** foldr :: (a -> b -> b) -> b -> [a] -> b ** 318 | performs a right __fold__ on a list 319 | you can see precisely what foldr is doing with the following function 320 | #Example:# 321 | > foldr (λx y -> "(" ++ x ++ " + " ++ y ++ ")") "0" (map show [1 to 5]) 322 | > "(1 + (2 + (3 + (4 + (5 + 0)))))" 323 | *) 324 | let foldr f acc xs = if empty? xs then acc else ((f (head xs)) (foldr f acc (tail xs))) 325 | 326 | (* 327 | ==foldl== 328 | ***foldl*** 329 | ** foldl :: (b -> a -> b) -> b -> [a] -> b ** 330 | performs a left __fold__ on a list 331 | you can see precisely what foldl is doing with the following function 332 | #Example:# 333 | > foldl (λx y -> "(" ++ x ++ " + " ++ y ++ ")") "0" (map show [1 to 5]) 334 | > "(((((0 + 1) + 2) + 3) + 4) + 5)" 335 | *) 336 | let foldl f acc xs = if empty? xs then acc else (foldl f (f acc (head xs)) (tail xs)) 337 | 338 | (* 339 | ==foldr1== 340 | ***foldr1*** 341 | ** foldr1 :: (a -> a -> a) -> [a] -> a ** 342 | *) 343 | let foldr1 f xs = foldr f (head xs) xs 344 | 345 | (* 346 | ==foldl1== 347 | ***foldl1*** 348 | ** foldl1 :: (a -> a -> a) -> [a] -> a ** 349 | *) 350 | let foldl1 f xs = foldl f (head xs) xs 351 | 352 | (* 353 | ==scanl== 354 | ***scanl*** 355 | ** scanl :: (b -> a -> b) -> b -> [a] -> [b] ** 356 | *) 357 | let scanl f x xs = if empty? xs then [] else x : (scanl f (f x (head xs)) (tail xs)) 358 | 359 | (* 360 | ==scanl1== 361 | ***scanl1*** 362 | ** scanl1 :: (b -> a -> b) -> b -> [a] -> [b] ** 363 | *) 364 | let scanl1 f xs = scanl f (head xs) (tail xs) 365 | 366 | (* 367 | ==scanr== 368 | ***scanr*** 369 | ** scanr :: (a -> b -> b) -> b -> [a] -> [b] ** 370 | *) 371 | let scanr f x xs = if empty? xs then [] else (f (head xs) x) : (scanr f x (tail xs)) 372 | 373 | (* 374 | ==map== 375 | ***map*** 376 | ** map :: (a -> b) -> [a] -> [b] ** 377 | performs the function (a -> b) on every element of the list [a]. Easier to see with an example. 378 | #Example:# 379 | > let succ x = x + 2 380 | > map pow [1 to 5] 381 | > [2, 4, 6, 8, 10] : [Number] 382 | > map (λx -> chr x) [109, 105, 99, 114, 111, 77, 76] 383 | > "microML" : String 384 | *) 385 | let map f xs = foldr (\x xs' -> (f x) : xs') [] xs 386 | 387 | (* 388 | ==concatMap== 389 | ***concatMap*** 390 | ** concatMap :: (a -> [b]) -> a -> [b] ** 391 | *) 392 | let concatMap f = foldr (\x y -> (f x) ++ y) []; 393 | 394 | (* 395 | ==filter== 396 | ***filter*** 397 | ** filter :: (a -> Boolean) -> [a] -> [a] ** 398 | *) 399 | let filter p xs = foldr (\x y -> if (p x) then (x:y) else y) [] xs 400 | 401 | (* 402 | ==init== 403 | ***init*** 404 | ** init :: [a] -> [a] ** 405 | *) 406 | let init xs = let l = (length xs) - 1 in if l == -1 then [] else take l xs 407 | 408 | (* 409 | ==reverse== 410 | ***reverse*** 411 | ** reverse :: [a] -> [a] ** 412 | *) 413 | let reverse xs = foldl (\x y -> y : x) [] xs 414 | 415 | (* 416 | ==last== 417 | ***last*** 418 | ** last :: [a] -> a ** 419 | *) 420 | let last xs = let l' = reverse xs in head l' 421 | 422 | (* 423 | ==sequence== 424 | ***sequence*** 425 | ** sequence :: [a] -> [a] -> [[a]] ** 426 | Finite sequence 427 | *) 428 | let sequence xs ys = let seq = \z bs -> foldr (\y a -> (z:y:[]):a) [] bs in if empty? xs then [] else (seq (head xs) ys) : (sequence (tail xs) ys) 429 | 430 | (* 431 | ==quicksort== 432 | ***quicksort*** 433 | ** quicksort :: [a] -> [a] ** 434 | sorts a list in ascending order, using the quicksort algorithm 435 | #Example:# 436 | > quicksort [7,4,5,2,8,1,10,3,6,9] 437 | > quicksort [1,2,3,4,5,6,7,8,9,10] 438 | *) 439 | let quicksort xs = let smaller = \xs -> filter (\x -> x < head xs) (tail xs) in let greater = \xs -> filter (\x -> x >= head xs) (tail xs) in if xs == [] then [] else (quicksort (smaller xs)) ++ [head xs] ++ (quicksort (greater xs)) 440 | 441 | (* 442 | ==merge== 443 | ***merge*** 444 | ** merge [a] -> [a] -> [a] ** 445 | merge is a helper function for mergesort 446 | *) 447 | let merge = \xs ys -> if ys == [] then xs else if xs == [] then ys else if (head xs) <= (head ys) then (head xs):(merge (tail xs) ys) else (head ys):(merge xs (tail ys)) 448 | 449 | (* 450 | ==mergesort== 451 | ***mergesort*** 452 | ** mergesort :: [a] -> [a] ** 453 | sorts a list in ascending order, using the mergesort algorithm 454 | #Example:# 455 | > mergesort [7,4,5,2,8,1,10,3,6,9] 456 | > mergesort [1,2,3,4,5,6,7,8,9,10] 457 | *) 458 | let mergesort xs = let fsthalf = \xs -> take ((length xs) // 2) xs in let sndhalf = \xs -> drop ((length xs) // 2) xs in if xs == [] then [] else if (length xs) == 1 then xs else merge (mergesort (fsthalf xs)) (mergesort (sndhalf xs)) 459 | -------------------------------------------------------------------------------- /src/Libs/string.mml: -------------------------------------------------------------------------------- 1 | (* 2 | ==chr== 3 | ***chr*** 4 | ** chr :: Number -> Char ** 5 | takes a number and returns the __ascii__ letter of that value 6 | #Example:# 7 | > chr 97 8 | > 'a' : Char 9 | *) 10 | let chr x = _chr x 11 | 12 | (* 13 | ==ord== 14 | ***ord*** 15 | ** ord :: Char -> Number ** 16 | takes an __ascii__ letter and returns its number 17 | #Example:# 18 | > ord 'a' 19 | > 97 : Number 20 | *) 21 | let ord x = _ord x 22 | 23 | (* 24 | ==toUpper== 25 | ***toUpper*** 26 | ** toUpper :: Char -> Char ** 27 | toUpper takes a lowercase letter and changes it to uppercase 28 | #Example:# 29 | > toUpper 'a' 30 | > 'A' : Char 31 | *) 32 | let toUpper x = chr ((ord x) - 32) 33 | 34 | (* 35 | ==toLower== 36 | ***toLower*** 37 | ** toLower :: Char -> Char ** 38 | toLower takes a lowercase letter and changes it to uppercase 39 | #Example:# 40 | > toLower 'A' 41 | > 'a' : Char 42 | *) 43 | let toLower x = chr ((ord x) + 32) 44 | 45 | (* 46 | ==pack== 47 | ***pack*** 48 | ** pack :: [Char] -> String ** 49 | strings are __immutable__ in microML, so if you want to do things to them you need to __unpack__ 50 | then and then pack them again. pack takes a list of chars and returns a string. 51 | #Example:# 52 | > pack ['h','e','l','l','o'] 53 | > "hello" : String 54 | *) 55 | let pack xs = foldr (\x y -> x : y) "" xs 56 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Compiler.CodeGen 4 | import Compiler.CallGraph 5 | import MicroML.Parser 6 | import MicroML.Syntax (red, clear) 7 | import Repl.Repl hiding (clear, hoistError) 8 | 9 | import System.IO (hPutStrLn, stderr) 10 | import System.Exit 11 | import System.Console.CmdArgs.GetOpt 12 | import System.Environment (getArgs) 13 | import System.Directory 14 | 15 | import qualified Data.Text.Lazy.IO as LIO 16 | import qualified Data.Text.Lazy as L 17 | import Data.List (nub) 18 | 19 | type File = String 20 | 21 | -- | command line options 22 | data Flag = 23 | Interpreter 24 | | Jit 25 | | Compiler 26 | | ObjectFile 27 | | CallGraph 28 | | Help 29 | deriving (Eq, Ord, Enum, Show, Bounded) 30 | 31 | -- | actions and help messages 32 | flags :: [OptDescr Flag] 33 | flags = 34 | [ Option ['j'] [] (NoArg Jit) 35 | "Runs the specified file(s) in the JIT compiler" 36 | , Option ['c'] [] (NoArg Compiler) 37 | "Compiles the specified file(s) to C++ for the bbc:microbit" 38 | , Option ['i'] [] (NoArg Interpreter) 39 | "Starts the microML interactive environment" 40 | , Option ['o'] [] (NoArg ObjectFile) 41 | "The name of the new file you want to save" 42 | , Option ['g'] [] (NoArg CallGraph) 43 | "Produces a png image of the program's call graph (how each function is linked to the others)" 44 | , Option [] ["help"] (NoArg Help) 45 | "Prints this help message" 46 | ] 47 | 48 | parseCmds :: [String] -> IO ([Flag], [String]) 49 | parseCmds argv = 50 | if null argv 51 | then do hPutStrLn stderr $ "Please enter one of the following option:\n" ++ usageInfo header flags 52 | exitFailure 53 | else 54 | case getOpt Permute flags argv of 55 | (args, fs, []) -> do 56 | let files = if null fs then ["-"] else fs 57 | if Help `elem` args 58 | then do hPutStrLn stderr (usageInfo header flags) 59 | exitSuccess 60 | else return (nub args, files) 61 | (_,_,errs) -> do 62 | hPutStrLn stderr (concat errs ++ usageInfo header flags) 63 | exitWith (ExitFailure 1) 64 | where header = "Usage: microML [-jcio] [file ...]" 65 | 66 | -- | sends flags and data to the correct part of microML 67 | microML :: Flag -> [FilePath] -> IO () 68 | microML arg fs = 69 | case arg of 70 | Interpreter -> shell 71 | ObjectFile -> undefined -- not yet implemented. Possibly to be removed? 72 | CallGraph -> 73 | if length fs /= 1 -- only accept one file at a time 74 | then die $ red ++ "Exit Failure: " ++ clear ++ "you must provide only one source file at a time. Sorry :(" 75 | else do 76 | contents <- LIO.readFile(head fs) 77 | let res = hoistError $ parseProgram "from file" contents 78 | drawGraph res 79 | Compiler -> 80 | if length fs /= 2 -- only accepts one file for the moment 81 | then die $ red ++ "Exit Failure: " ++ clear ++ "you must provide a source file and a destination file" 82 | else do 83 | tr <- doesFileExist $ head fs 84 | if tr 85 | then do 86 | contents <- LIO.readFile (head fs) 87 | compile contents (L.pack $ last fs) (head fs) 88 | else die $ red ++ "Exit Failure: " ++ clear ++ "the given file doesn't exist in that location, so it can't be compiled!" 89 | Jit -> do -- die "The jit is not yet operable" 90 | exists <- findExecutable "llc" 91 | if null exists 92 | then die $ "Unable to find" ++ red ++ " LLVM " ++ clear ++ " on your computer." 93 | ++ " Are you sure it is installed?" 94 | else die "This jit is not yet operable" 95 | 96 | -- | this is it: the main entry point for microML 97 | main :: IO () 98 | main = do 99 | (args, files) <- getArgs >>= parseCmds 100 | microML (head args) files 101 | -------------------------------------------------------------------------------- /src/MicroML/Config.hs: -------------------------------------------------------------------------------- 1 | module MicroML.Config where 2 | 3 | import MicroML.Syntax (clear) 4 | 5 | import Data.ConfigFile 6 | import System.Terminfo 7 | import qualified System.Terminfo.Caps as C 8 | import System.Environment (lookupEnv) 9 | import Data.Maybe (fromJust) 10 | import qualified Data.Map as Map 11 | import Data.List (isInfixOf) 12 | 13 | type ConfigEnv = Map.Map OptionSpec String 14 | 15 | configEmpty :: ConfigEnv 16 | configEmpty = Map.empty 17 | 18 | maxColours :: IO (Maybe Int) 19 | maxColours = do 20 | term <- fromJust <$> lookupEnv "TERM" 21 | db <- acquireDatabase term 22 | let colours (Right d) = queryNumTermCap d C.MaxColors 23 | return $ colours db 24 | 25 | escapeCode :: String -> String 26 | escapeCode "15" = "\ESC[" 27 | escapeCode "255" = "\ESC[38;5;" 28 | escapeCode _ = error "unsupported terminal type" 29 | 30 | getColour :: ConfigEnv -> String -> String 31 | getColour env colour = fromJust (Map.lookup colour env) 32 | 33 | checkRange :: [(String, String)] -> Int -> Bool 34 | checkRange = undefined 35 | 36 | escape :: [(String, String)] -> String -> [(String, String)] 37 | escape xs term = map (\(x,y) -> if x == "bold" then new x y esc' else new x y esc) xs 38 | where esc = escapeCode term 39 | esc' = "\ESC[" 40 | new x y code = (x, code ++ y ++ "m") 41 | 42 | -- | an unfortunate function brought about by the fact that I only thought about adding a 43 | -- configuration file near to the project deadline. It would be much better to wrap this all in some 44 | -- prettyprint monad of some sort. That's another element in the TODO list... 45 | putColour :: ConfigEnv -> String -> String 46 | putColour conf = unwords . pc . words 47 | where pc [] = [] 48 | pc (x:xs) 49 | | x == "Number" = (getColour conf "number" ++ x ++ clear) : pc xs 50 | | x == "(Number" = ('(' : (getColour conf "number" ++ "Number" ++ clear)) : pc xs 51 | | x == "Number)" = ((getColour conf "number" ++ "Number" ++ clear) ++ ")") : pc xs 52 | | "Number" `isInfixOf` x = ((opening ++ (getColour conf "number" ++ ty x ++ clear)) ++ closing) : pc xs 53 | 54 | | x == "String" = (getColour conf "string" ++ x ++ clear) : pc xs 55 | | x == "(String" = ('(' : (getColour conf "string" ++ x ++ clear)) : pc xs 56 | | x == "String)" = ((getColour conf "string" ++ x ++ clear) ++ ")") : pc xs 57 | | "String" `isInfixOf` x = ((opening ++ (getColour conf "string" ++ ty x ++ clear)) ++ closing) : pc xs 58 | 59 | | x == "Char" = (getColour conf "char" ++ x ++ clear) : pc xs 60 | | x == "(Char" = ('(' : (getColour conf "char" ++ x ++ clear)) : pc xs 61 | | x == "Char)" = ((getColour conf "char" ++ x ++ clear) ++ ")") : pc xs 62 | | "Char" `isInfixOf` x = ((opening ++ (getColour conf "char" ++ ty x ++ clear)) ++ closing) : pc xs 63 | 64 | | x == "Boolean" = (getColour conf "boolean" ++ x ++ clear) : pc xs 65 | | x == "(Boolean" = ('(' : (getColour conf "boolean" ++ "Boolean" ++ clear)) : pc xs 66 | | x == "Boolean)" = (getColour conf "boolean" ++ "Boolean" ++ clear ++ ")") : pc xs 67 | | "Boolean" `isInfixOf` x = ((opening ++ (getColour conf "bool" ++ ty x ++ clear)) ++ closing) : pc xs 68 | 69 | | x == "Error" = (getColour conf "error" ++ x ++ clear) : pc xs 70 | | x == "→" = (getColour conf "arrow" ++ x ++ clear) : pc xs 71 | | otherwise = x : pc xs 72 | where ty = filter (\x -> x /= '[' && x /= ']') 73 | opening = concat $ replicate times "[" 74 | closing = concat $ replicate times "]" 75 | times = length $ filter (== '[') x 76 | -------------------------------------------------------------------------------- /src/MicroML/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | module MicroML.Lexer where 4 | 5 | import Text.Parsec 6 | import Text.Parsec.Text.Lazy 7 | import qualified Data.Text.Lazy as L 8 | import qualified Text.Parsec.Token as Tok 9 | import qualified Text.Parsec.Expr as Ex 10 | 11 | import Data.Functor.Identity 12 | 13 | type Op a = Ex.Operator L.Text () Identity a 14 | type Operators a = Ex.OperatorTable L.Text () Identity a 15 | 16 | reservedNames :: [String] 17 | reservedNames = [ "let", "in", "if", "then", "else", "case", "of", "and", 18 | "or", "not", "xor", "head", "tail", "to", "where", "true", "false", "try", "except", "using" ] 19 | 20 | reservedOps :: [String] 21 | reservedOps = [ "->", "\\", "+", "*", "-", "=", "==", "%", "^", "/", "<=", ">=", ">", "<", ":", "_", "++", "::="] 22 | 23 | lexer :: Tok.GenTokenParser L.Text () Identity 24 | lexer = Tok.makeTokenParser Tok.LanguageDef 25 | { Tok.commentStart = "(*" 26 | , Tok.commentEnd = "*)" 27 | , Tok.commentLine = "--" 28 | , Tok.nestedComments = True 29 | , Tok.identStart = letter 30 | , Tok.identLetter = alphaNum <|> oneOf "_'?" 31 | , Tok.opStart = oneOf ":!$%&*+./<=>?@\\^|-~" 32 | , Tok.opLetter = oneOf ":!$%&*+./<=>?@\\^|-~" 33 | , Tok.reservedNames = reservedNames 34 | , Tok.reservedOpNames = reservedOps 35 | , Tok.caseSensitive = True 36 | } 37 | 38 | reserved = Tok.reserved lexer 39 | reservedOp = Tok.reservedOp lexer 40 | identifier = Tok.identifier lexer 41 | parens = Tok.parens lexer 42 | brackets = Tok.brackets lexer 43 | braces = Tok.braces lexer 44 | comma = Tok.commaSep lexer 45 | semi = Tok.semi lexer 46 | integer = Tok.integer lexer 47 | chr = Tok.charLiteral lexer 48 | str = Tok.stringLiteral lexer 49 | commaSep = Tok.commaSep lexer 50 | 51 | contents :: Parser a -> Parser a 52 | contents p = do 53 | Tok.whiteSpace lexer 54 | r <- p 55 | eof 56 | return r 57 | -------------------------------------------------------------------------------- /src/MicroML/ListPrimitives.hs: -------------------------------------------------------------------------------- 1 | module MicroML.ListPrimitives where 2 | 3 | import MicroML.Syntax 4 | 5 | import qualified Data.Char as DC 6 | 7 | -- | doesn't work yet for vars 8 | enumFromTo_ :: Expr -> Expr -> Expr 9 | enumFromTo_ (Lit (LInt a)) (Lit (LInt b)) = List $ foldr (BinOp OpCons) Nil $ (Lit . LInt ) <$> [a .. b] 10 | enumFromTo_ (Lit (LDouble a)) (Lit (LDouble b)) = List $ foldr (BinOp OpCons) Nil $ (Lit . LDouble ) <$> [a .. b] 11 | enumFromTo_ (Lit (LChar a)) (Lit (LChar b)) = List $ foldr (BinOp OpCons) Nil $ (Lit . LChar) <$> [a .. b] 12 | enumFromTo_ _ _ = PrimitiveErr $ ListPrim "" 13 | 14 | car :: Expr -> Expr 15 | car (BinOp OpCons x _) = x 16 | car (List (BinOp OpCons x _)) = x 17 | car (Lit (LString x)) = Lit . LChar $ head x 18 | 19 | cdr :: Expr -> Expr 20 | cdr (BinOp OpCons _ xs) = xs 21 | cdr (List (BinOp OpCons _ xs)) = List xs 22 | cdr (Lit (LString xs)) = Lit . LString $ tail xs 23 | 24 | cons :: Expr -> Expr -> Expr 25 | cons a (List xs) = List $ cons a xs 26 | cons a Nil = BinOp OpCons a Nil 27 | cons a (BinOp OpCons x Nil) = BinOp OpCons a (BinOp OpCons x Nil) 28 | cons a ls@(BinOp OpCons _ _) = BinOp OpCons a ls 29 | cons (Lit (LChar x)) (Lit (LString y)) = Lit . LString $ x : y 30 | cons x y = error $ show x ++ " " ++ show y 31 | 32 | append :: Expr -> Expr -> Expr 33 | append xs Nil = xs 34 | append Nil xs = xs 35 | append (List xs) (List ys) = List $ append xs ys 36 | append (BinOp OpCons x Nil) xs@(BinOp OpCons _ _) = BinOp OpCons x xs 37 | append (BinOp OpCons x xs) ys = BinOp OpCons x (append xs ys) 38 | append (Lit (LString x)) (Lit (LString y)) = Lit . LString $ x ++ y 39 | append x y = PrimitiveErr $ ListPrim $ show x ++ " " ++ show y 40 | 41 | ------------------------------------ 42 | -- STRING MANIPULATION PRIMITIVES -- 43 | ------------------------------------ 44 | 45 | show' :: Expr -> Expr 46 | show' str@(Lit (LString _)) = str 47 | show' (Lit (LInt x)) = Lit . LString $ show x 48 | show' (Lit (LDouble x)) = Lit . LString $ show x 49 | show' (Lit (LChar x)) = Lit . LString $ [x] 50 | show' (Lit (LBoolean True)) = Lit (LString "true") 51 | show' (Lit (LBoolean False)) = Lit (LString "false") 52 | show' _ = PrimitiveErr $ ListPrim "this is not a Showable object" 53 | 54 | -- this doesn't handle binary, octal or hex yet 55 | read' :: Expr -> Expr 56 | read' (Lit (LString x)) = 57 | let removeDot = filter (/= '.') 58 | in if all DC.isNumber $ removeDot x 59 | then if '.' `elem` x 60 | then Lit . LDouble $ read x 61 | else Lit . LInt $ read x 62 | else PrimitiveErr $ ListPrim "the string does not contain a number" 63 | 64 | ord' :: Expr -> Expr 65 | ord' (Lit (LChar a)) = Lit . LInt $ (toInteger . DC.ord) a 66 | ord' _ = PrimitiveErr $ ListPrim "this function only works on type Char" 67 | 68 | chr' :: Expr -> Expr 69 | chr' (Lit (LInt n)) = Lit . LChar $ (DC.chr . fromIntegral) n 70 | chr' _ = PrimitiveErr $ ListPrim "this function only works on type Char" 71 | -------------------------------------------------------------------------------- /src/MicroML/MathsPrimitives.hs: -------------------------------------------------------------------------------- 1 | module MicroML.MathsPrimitives where 2 | 3 | import MicroML.Syntax 4 | import Data.List (isInfixOf) 5 | import Data.List.Split (splitOn) 6 | import Data.Bits (xor) 7 | 8 | add :: Expr -> Expr -> Expr 9 | add (Lit (LInt a)) (Lit (LInt b)) = Lit $ LInt $ a + b 10 | add (Lit (LDouble a)) (Lit (LDouble b)) = Lit $ LDouble $ a + b 11 | add (Lit (LInt a)) (Lit (LDouble b)) = Lit $ LDouble $ realToFrac a + b 12 | add (Lit (LDouble a)) (Lit (LInt b)) = Lit $ LDouble $ a + realToFrac b 13 | 14 | or', and', xor' :: Expr -> Expr -> Expr 15 | or' (Lit (LBoolean a)) (Lit (LBoolean b)) = Lit $ LBoolean $ a || b 16 | and' (Lit (LBoolean a)) (Lit (LBoolean b)) = Lit $ LBoolean $ a && b 17 | xor' (Lit (LBoolean a)) (Lit (LBoolean b)) = Lit $ LBoolean $ a `xor` b 18 | 19 | sub :: Expr -> Expr -> Expr 20 | sub (Lit (LInt a)) (Lit (LInt b)) = Lit $ LInt $ a - b 21 | sub (Lit (LDouble a)) (Lit (LDouble b)) = Lit $ LDouble $ truncate' $ a - b 22 | sub (Lit (LInt a)) (Lit (LDouble b)) = Lit . LDouble . truncate' $ realToFrac a - b 23 | sub (Lit (LDouble a)) (Lit (LInt b)) = Lit . LDouble . truncate' $ a - realToFrac b 24 | sub _ _ = error "incorrect arguments" 25 | 26 | mul :: Expr -> Expr -> Expr 27 | mul (Lit (LInt a)) (Lit (LInt b)) = Lit $ LInt $ a * b 28 | mul (Lit (LDouble a)) (Lit (LDouble b)) = Lit . LDouble . truncate' $ a * b 29 | mul (Lit (LInt a)) (Lit (LDouble b)) = Lit . LDouble . truncate' $ realToFrac a * b 30 | mul (Lit (LDouble a)) (Lit (LInt b)) = Lit . LDouble . truncate' $ a * realToFrac b 31 | 32 | div' :: Expr -> Expr -> Expr 33 | div' (Lit (LInt a)) (Lit (LInt b)) = Lit $ LDouble $ realToFrac a / realToFrac b 34 | div' (Lit (LDouble a)) (Lit (LDouble b)) = Lit $ LDouble $ a / b 35 | div' (Lit (LInt a)) (Lit (LDouble b)) = Lit $ LDouble $ realToFrac a / b 36 | div' (Lit (LDouble a)) (Lit (LInt b)) = Lit $ LDouble $ a / realToFrac b 37 | 38 | intDiv :: Expr -> Expr -> Expr 39 | intDiv (Lit (LInt a)) (Lit (LInt b)) = Lit . LInt $ a `div` b 40 | intDiv (Lit (LDouble a)) (Lit (LDouble b)) = Lit $ LInt $ floor a `div` floor b 41 | intDiv (Lit (LInt a)) (Lit (LDouble b)) = Lit $ LInt $ a `div` floor b 42 | intDiv (Lit (LDouble a)) (Lit (LInt b)) = Lit $ LInt $ floor a `div` b 43 | 44 | mod' :: Expr -> Expr -> Expr 45 | mod' (Lit (LInt a)) (Lit (LInt b)) = Lit $ LInt $ a `mod` b 46 | mod' _ _ = error "only works on integers" -- improve this 47 | 48 | exp' :: Expr -> Expr -> Expr 49 | exp' (Lit (LInt a)) (Lit (LInt b)) = Lit $ LInt $ a^b 50 | exp' (Lit (LInt a)) (Lit (LDouble b)) = Lit $ LDouble $ realToFrac a**b 51 | exp' (Lit (LDouble a)) (Lit (LInt b)) = Lit $ LDouble $ a ^ b 52 | exp' (Lit (LDouble a)) (Lit (LDouble b)) = Lit $ LDouble $ a**b 53 | 54 | log' :: Expr -> Expr 55 | log' (Lit (LInt a)) = Lit . LDouble $ log $ realToFrac a 56 | log' (Lit (LDouble a)) = Lit . LDouble $ log a 57 | 58 | opEq :: Expr -> Expr -> Expr 59 | opEq (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a == b 60 | opEq (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a == realToFrac b 61 | opEq a b = Lit . LBoolean $ a == b 62 | 63 | opLe :: Expr -> Expr -> Expr 64 | opLe (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a <= b 65 | opLe (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a <= realToFrac b 66 | opLe a b = Lit . LBoolean $ a <= b 67 | 68 | opLt :: Expr -> Expr -> Expr 69 | opLt (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a < b 70 | opLt (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a < realToFrac b 71 | opLt a b = Lit . LBoolean $ a < b 72 | 73 | opGt :: Expr -> Expr -> Expr 74 | opGt (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a > b 75 | opGt (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a > realToFrac b 76 | opGt a b = Lit . LBoolean $ a > b 77 | 78 | opGe :: Expr -> Expr -> Expr 79 | opGe (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a >= b 80 | opGe (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a >= realToFrac b 81 | opGe a b = Lit . LBoolean $ a >= b 82 | 83 | opNotEq :: Expr -> Expr -> Expr 84 | opNotEq (Lit (LInt a)) (Lit (LDouble b)) = Lit . LBoolean $ realToFrac a /= b 85 | opNotEq (Lit (LDouble a)) (Lit (LInt b)) = Lit . LBoolean $ a /= realToFrac b 86 | opNotEq a b = Lit . LBoolean $ a /= b 87 | 88 | -- | an arbitrary truncation of floating-point rounding errors. It's unlikely that this will be a 89 | -- problem for students. Horrible horrible code though. 90 | -- TODO find an elegant mathematical solution to this problem, rather than nasty string manipulation 91 | truncate' :: Double -> Double 92 | truncate' = read . dropZeros . show 93 | where dropZeros x = head (split x) ++ "." ++ getValid (head (tail (split x))) 94 | split = splitOn "." 95 | getValid s 96 | | "e" `isInfixOf` s = s 97 | | hasform s = if length s == 1 then s else show $ (read [head s] :: Int) + 1 98 | | take 3 s == "000" = "0" 99 | | otherwise = head s : getValid (tail s) 100 | 101 | hasform :: String -> Bool 102 | hasform (_:ys) = all (== '9') ys 103 | -------------------------------------------------------------------------------- /src/MicroML/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module MicroML.Parser (parseProgram) where 4 | 5 | import Text.Parsec 6 | import Text.Parsec.Text.Lazy (Parser) 7 | 8 | import qualified Text.Parsec.Expr as Ex 9 | import qualified Text.Parsec.Token as Tok 10 | 11 | import Data.Char (isLower, isUpper, digitToInt) 12 | import Data.List (foldl') 13 | import Numeric (readOct, readHex) 14 | import qualified Data.Text.Lazy as L 15 | 16 | import Control.Monad.Identity (Identity) 17 | import Control.Monad (void) 18 | 19 | import MicroML.Lexer 20 | import qualified MicroML.Lexer as Lx 21 | import MicroML.Syntax 22 | 23 | varName :: Parser String 24 | varName = do 25 | name@(n:_) <- identifier 26 | if isLower n 27 | then return name 28 | else fail "a variable name must start with a lowercase letter" 29 | 30 | constructorName :: Parser String 31 | constructorName = do 32 | name@(n:_) <- identifier 33 | if isUpper n 34 | then return name 35 | else fail "a constructor must start with a capital letter" 36 | 37 | float :: Parser Double 38 | float = Tok.float lexer 39 | 40 | variable :: Parser Expr 41 | variable = varName >>= \n -> return $ Var n 42 | 43 | constructor :: Parser Expr 44 | constructor = constructorName >>= \c -> return $ Constructor c 45 | 46 | number :: Parser Expr 47 | number = Lx.integer >>= \n -> return (Lit (LInt n)) 48 | 49 | double :: Parser Expr 50 | double = float >>= \d -> return (Lit (LDouble d)) 51 | 52 | {- base formats use erlang style syntax, ie. 2#, 8# ad 16# -} 53 | binary :: Parser Expr 54 | binary = do 55 | void spaces 56 | _ <- string "2#" 57 | b <- many1 $ oneOf "10" 58 | void spaces 59 | return $ Lit (LInt $ readBin b) 60 | where readBin = foldl' (\x y -> x*2 + y) 0 . map (fromIntegral . digitToInt) 61 | 62 | octal :: Parser Expr 63 | octal = do 64 | void spaces 65 | _ <- string "8#" 66 | o <- many1 octDigit 67 | void spaces 68 | return $ Lit (LInt $ baseToDec readOct o) 69 | 70 | hex :: Parser Expr 71 | hex = do 72 | void spaces 73 | _ <- string "16#" 74 | h <- many1 hexDigit 75 | void spaces 76 | return $ Lit (LInt $ baseToDec readHex h) 77 | 78 | -- readHex and readOct return lists of tuples, so this function simply lifts out the 79 | -- desired number 80 | baseToDec :: (t -> [(c, b)]) -> t -> c 81 | baseToDec f n = (fst . head) $ f n 82 | 83 | charLit :: Parser Expr 84 | charLit = do 85 | spaces 86 | void $ char '\'' 87 | c <- letter 88 | void $ char '\'' 89 | spaces 90 | return $ Lit (LChar c) 91 | 92 | stringLit :: Parser Expr 93 | stringLit = do 94 | void spaces 95 | void $ char '"' 96 | s <- many $ escaped <|> noneOf "\"\\" 97 | void $ char '"' 98 | void spaces 99 | return $ Lit (LString s) 100 | 101 | escaped :: ParsecT L.Text u Identity Char 102 | escaped = do 103 | void $ char '\\' 104 | x <- oneOf "\\\"nrt" 105 | return $ case x of 106 | ' ' -> x 107 | '\\' -> x 108 | '"' -> x 109 | 'n' -> '\n' 110 | 'r' -> '\r' 111 | 't' -> '\t' 112 | 113 | bool :: Parser Expr 114 | bool = (reserved "true" >> return (Lit (LBoolean True))) 115 | <|> (reserved "false" >> return (Lit (LBoolean False))) 116 | 117 | list :: Parser Expr 118 | list = do 119 | void $ spaces *> char '[' 120 | elems <- commaSep expr 121 | void $ char ']' <* spaces 122 | return $ List $ foldr (BinOp OpCons) Nil elems 123 | 124 | tuple :: Parser Expr 125 | tuple = do 126 | void $ string "{" 127 | elems <- commaSep expr 128 | void $ string "}" 129 | void spaces 130 | return $ Lit $ LTup elems 131 | 132 | lambda :: Parser Expr 133 | lambda = do 134 | reservedOp "\\" 135 | args <- many varName 136 | reservedOp "->" 137 | body <- expr 138 | return $ foldr Lam body args 139 | 140 | letrecin :: Parser Expr 141 | letrecin = do 142 | reserved "let" 143 | x <- varName 144 | reservedOp "=" 145 | void spaces 146 | e1 <- expr 147 | void spaces 148 | reserved "in" 149 | void spaces 150 | e2 <- expr 151 | void spaces 152 | return (Let x e1 e2) 153 | 154 | ifthen :: Parser Expr 155 | ifthen = do 156 | reserved "if" 157 | void spaces 158 | cond <- expr 159 | void spaces 160 | reservedOp "then" 161 | void spaces 162 | tr <- expr 163 | void spaces 164 | reserved "else" 165 | void spaces 166 | fl <- expr 167 | void spaces 168 | return (If cond tr fl) 169 | 170 | aexp :: Parser Expr 171 | aexp = 172 | parens expr 173 | <|> try tuple 174 | <|> bool 175 | <|> try binary 176 | <|> try octal 177 | <|> try hex 178 | <|> try double 179 | <|> number 180 | <|> ifthen 181 | <|> try parseRange 182 | <|> list 183 | <|> try letrecin 184 | <|> lambda 185 | <|> variable 186 | <|> stringLit 187 | <|> charLit 188 | "an expression" 189 | 190 | term :: Parser Expr 191 | term = Ex.buildExpressionParser primitives aexp "an expression or primitive type (such as a number)" 192 | 193 | infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a 194 | infixOp x f = Ex.Infix (reservedOp x >> return f) 195 | 196 | prefixOp :: String -> (a -> a) -> Ex.Operator L.Text () Identity a 197 | prefixOp name func = Ex.Prefix ( do {reservedOp name; return func } ) 198 | 199 | primitives :: [[Op Expr]] 200 | primitives = [[ prefixOp "head" (UnaryOp Car) 201 | , prefixOp "tail" (UnaryOp Cdr) 202 | , prefixOp "_read" (UnaryOp Read) 203 | , prefixOp "_show" (UnaryOp Show) 204 | , prefixOp "_ord" (UnaryOp Ord) 205 | , prefixOp "_chr" (UnaryOp Chr) 206 | , prefixOp "-" (UnaryOp Minus) 207 | , infixOp ":" (BinOp OpCons) Ex.AssocRight 208 | , infixOp "++" (BinOp OpAppend) Ex.AssocRight ] 209 | , [ prefixOp "_log" (UnaryOp OpLog) 210 | , infixOp "^" (BinOp OpExp) Ex.AssocLeft ] -- maths operators 211 | , [ infixOp "*" (BinOp OpMul) Ex.AssocLeft 212 | , infixOp "//" (BinOp OpIntDiv) Ex.AssocLeft 213 | , infixOp "/" (BinOp OpDiv) Ex.AssocLeft 214 | , infixOp "%" (BinOp OpMod) Ex.AssocLeft ] 215 | , [ infixOp "+" (BinOp OpAdd) Ex.AssocLeft 216 | , infixOp "-" (BinOp OpSub) Ex.AssocLeft ] 217 | , [ infixOp "<=" (BinOp OpLe) Ex.AssocLeft -- boolean operators 218 | , infixOp ">=" (BinOp OpGe) Ex.AssocLeft 219 | , infixOp "<" (BinOp OpLt) Ex.AssocLeft 220 | , infixOp ">" (BinOp OpGt) Ex.AssocLeft ] 221 | , [ infixOp "==" (BinOp OpEq) Ex.AssocLeft 222 | , infixOp "/=" (BinOp OpNotEq) Ex.AssocLeft ] 223 | , [ infixOp "and" (BinOp OpAnd) Ex.AssocLeft 224 | , infixOp "or" (BinOp OpOr) Ex.AssocLeft 225 | , infixOp "xor" (BinOp OpXor) Ex.AssocLeft 226 | , prefixOp "not" (UnaryOp Not) ] 227 | , [ infixOp ">>" (BinOp OpPipe) Ex.AssocLeft ]] 228 | 229 | expr :: Parser Expr 230 | expr = do 231 | es <- many1 term 232 | return (foldl1 App es) 233 | 234 | parseRange :: Parser Expr 235 | parseRange = do 236 | void $ string "[" 237 | start <- expr 238 | void $ reserved "to" 239 | end <- expr 240 | void $ string "]" 241 | return $ BinOp OpEnum start end 242 | 243 | ------------------ 244 | -- DECLARATIONS -- 245 | ------------------ 246 | 247 | type Binding = (String, Expr) 248 | 249 | -- placeholders for datatype parser 250 | dataDecl :: Parser Binding 251 | dataDecl = do 252 | name <- constructorName 253 | params <- many varName 254 | reservedOp "::=" 255 | types <- datatype `sepBy` string "|" 256 | return (name, Constructor name) 257 | 258 | datatype :: Parser Expr 259 | datatype = do 260 | void spaces 261 | name <- constructorName 262 | params <- many varName 263 | void spaces 264 | return $ Constructor name 265 | 266 | letDecl :: Parser Binding 267 | letDecl = do 268 | reserved "let" 269 | name <- varName 270 | args <- many varName 271 | void $ reservedOp "=" 272 | body <- expr 273 | if name `elem` (words . removeControlChar . show) body 274 | then return (name, FixPoint $ foldr Lam body (name:args)) 275 | else return (name, foldr Lam body args) 276 | where removeControlChar = filter (\x -> x `notElem` ['(', ')', '\"']) 277 | 278 | val :: Parser Binding 279 | val = do 280 | ex <- expr 281 | return ("it", ex) 282 | 283 | decl :: Parser Binding 284 | decl = try val 285 | <|> letDecl 286 | <|> dataDecl 287 | "a declaration" 288 | 289 | top :: Parser Binding 290 | top = do 291 | x <- decl 292 | optional semi 293 | return x 294 | 295 | modl :: Parser [Binding] 296 | modl = many top 297 | 298 | parseProgram :: FilePath -> L.Text -> Either ParseError [(String, Expr)] 299 | parseProgram = parse (contents modl) 300 | -------------------------------------------------------------------------------- /src/MicroML/Syntax.hs: -------------------------------------------------------------------------------- 1 | module MicroML.Syntax where 2 | 3 | import qualified Data.Map as Map 4 | 5 | -------------------- 6 | -- TYPES SYNONYMS -- 7 | -------------------- 8 | 9 | type TermEnv = Map.Map String Expr 10 | type Name = String 11 | type VarName = String 12 | type ConName = String 13 | type Decl = (String, Expr) 14 | type ErrorMsg = String 15 | 16 | ---------- 17 | -- ADTs -- 18 | ---------- 19 | 20 | data Program = Program [Decl] Expr deriving Eq 21 | 22 | data Expr 23 | = Var Name 24 | | Constructor Name 25 | | App Expr Expr 26 | | Lam Name Expr 27 | | Let Name Expr Expr 28 | | Lit Lit 29 | | If Expr Expr Expr 30 | | FixPoint Expr 31 | | BinOp Binop Expr Expr 32 | | UnaryOp UnaryOp Expr 33 | | Closure Name Expr TermEnv 34 | | PrimitiveErr MLError 35 | | List Expr 36 | | Nil 37 | deriving (Show, Eq, Ord) 38 | 39 | data Lit 40 | = LInt Integer 41 | | LDouble Double 42 | | LBoolean Bool 43 | | LString String 44 | | LChar Char 45 | | LTup [Expr] 46 | 47 | deriving (Show, Eq, Ord) 48 | 49 | data UnaryOp = 50 | Chr | Ord | Read | Show 51 | | Car | Cdr 52 | | Not | Minus | OpLog -- unary maths ops 53 | deriving (Eq, Ord) 54 | 55 | instance Show UnaryOp where 56 | show Car = "Car" 57 | show Cdr = "Cdr" 58 | show Minus = "negative" 59 | show OpLog = "log" 60 | show Show = "show" 61 | show Read = "read" 62 | show Chr = "chr" 63 | show Ord = "ord" 64 | show Not = "not" 65 | 66 | data Binop = 67 | OpAdd | OpSub | OpMul | OpDiv | OpIntDiv | OpExp | OpMod 68 | | OpOr | OpXor | OpAnd | OpEq | OpLe | OpLt | OpGe 69 | | OpGt | OpNotEq | OpCons | OpAppend | OpPipe | OpEnum 70 | deriving (Eq, Ord) 71 | 72 | instance Show Binop where 73 | show OpAdd = "addition" 74 | show OpSub = "subtraction" 75 | show OpMul = "multiplication" 76 | show OpDiv = "division" 77 | show OpIntDiv = "integer division" 78 | show OpExp = "exponent" 79 | show OpMod = "modulo" 80 | show OpOr = "inclusive or" 81 | show OpXor = "exclusive or" 82 | show OpAnd = "logical and" 83 | show OpEq = "equals" 84 | show OpLe = "less than or equal to" 85 | show OpLt = "less than" 86 | show OpGe = "greater than or equal to" 87 | show OpGt = "greater than" 88 | show OpNotEq = "not equal to" 89 | show OpCons = "Cons" 90 | show OpAppend = "concatenation" 91 | show OpPipe = "pipe" 92 | show OpEnum = "enum" 93 | 94 | data MLError 95 | = MathsPrim String 96 | | ListPrim String 97 | | CharPrim String 98 | deriving (Eq, Ord) 99 | 100 | instance Show MLError where 101 | show (MathsPrim str) = str 102 | show (ListPrim str) = str 103 | show (CharPrim str) = str 104 | 105 | ----------------- 106 | -- HELPER DEFS -- 107 | ----------------- 108 | 109 | red, clear, bold :: String 110 | red = "\ESC[31m" 111 | clear = "\ESC[0m" 112 | bold = "\ESC[1m" 113 | -------------------------------------------------------------------------------- /src/MicroML/Typing/Env.hs: -------------------------------------------------------------------------------- 1 | module MicroML.Typing.Env where 2 | 3 | import MicroML.Syntax 4 | import MicroML.Typing.Type 5 | 6 | import qualified Data.Map as Map 7 | 8 | data Env = TypeEnv { types :: Map.Map Name TypeScheme } 9 | deriving (Eq, Show) 10 | 11 | empty :: Env 12 | empty = TypeEnv Map.empty 13 | 14 | -- unfortunately the type checker can't expose the types of built-in functions if 15 | -- requested in the repl (using the :typeof of :browse commands 16 | -- a simple fix is to add them in manually here, but it's a little bit of a kludge 17 | polyA :: TVar 18 | polyA = TV "a" 19 | 20 | microbit :: Env 21 | microbit = TypeEnv $ Map.fromList 22 | [ ("scroll" , Forall [polyA] $ TArrow (TVar polyA) (TVar polyA)) 23 | , ("head" , Forall [TV "[a]"] $ TArrow (TVar $ TV "[a]") (TVar polyA)) 24 | , ("tail" , Forall [TV "[a]"] $ TArrow (TVar $ TV "[a]") (TVar $ TV "[a]")) 25 | --, (":" , Forall [TV "a", TV "[a]"] $ (TVar $ TV "a") `TArrow` (TVar $ TV "[a]") `TArrow` (TVar $ TV "[a]")) 26 | , (":" , Forall [polyA] $ TVar polyA `TArrow` (TVar $ TV "[a]") `TArrow` (TVar $ TV "[a]")) 27 | , ("+" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 28 | , ("-" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 29 | , ("/" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 30 | , ("//" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 31 | , ("%" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 32 | , ("^" , Forall [] $ TArrow typeNum (TArrow typeNum typeNum)) 33 | , ("==" , Forall [] $ TArrow (TVar polyA) (TArrow (TVar polyA) typeBool)) 34 | , (">>" , Forall [polyA, TV "b"] $ TVar polyA `TArrow` (TVar polyA `TArrow` TVar (TV "b") `TArrow` (TVar $ TV "b"))) 35 | , ("show" , Forall [polyA] $ TVar polyA `TArrow` typeString) 36 | , ("read" , Forall [] $ typeString `TArrow` typeNum) 37 | ] 38 | 39 | lookup :: Name -> Env -> Maybe TypeScheme 40 | lookup k (TypeEnv env) = Map.lookup k env 41 | 42 | extend :: Env -> (Name , TypeScheme) -> Env 43 | extend env (var, ts) = env { types = Map.insert var ts (types env) } 44 | 45 | restrict :: Env -> Name -> Env 46 | restrict (TypeEnv env) n = TypeEnv $ Map.delete n env 47 | 48 | merge :: Env -> Env -> Env 49 | merge (TypeEnv a) (TypeEnv b) = TypeEnv (Map.union a b) 50 | 51 | instance Monoid Env where 52 | mempty = empty 53 | mappend = merge 54 | -------------------------------------------------------------------------------- /src/MicroML/Typing/Substitutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module MicroML.Typing.Substitutable where 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | import Control.Monad.Except 10 | import Control.Monad.Identity 11 | 12 | import MicroML.Typing.Env 13 | import MicroML.Typing.Type 14 | import MicroML.Typing.TypeError 15 | 16 | type Unifier = (Subst, [Constraint]) 17 | 18 | -- | Constraint solver monad 19 | type Solve a = ExceptT TypeError Identity a 20 | 21 | newtype Subst = Subst (Map.Map TVar Type) 22 | deriving (Eq, Ord, Show, Monoid) 23 | 24 | class Substitutable a where 25 | apply :: Subst -> a -> a 26 | ftv :: a -> Set.Set TVar 27 | 28 | instance Substitutable Type where 29 | apply _ (TCon a) = TCon a 30 | apply (Subst s) t@(TVar a) = Map.findWithDefault t a s 31 | apply s (t1 `TArrow` t2) = apply s t1 `TArrow` apply s t2 32 | 33 | ftv TCon{} = Set.empty 34 | ftv (TVar a) = Set.singleton a 35 | ftv (t1 `TArrow` t2) = ftv t1 `Set.union` ftv t2 36 | 37 | instance Substitutable TypeScheme where 38 | apply (Subst s) (Forall as t) = Forall as $ apply s' t 39 | where s' = Subst $ foldr Map.delete s as 40 | ftv (Forall as t) = ftv t `Set.difference` Set.fromList as 41 | 42 | instance Substitutable Constraint where 43 | apply s (t1, t2) = (apply s t1, apply s t2) 44 | ftv (t1, t2) = ftv t1 `Set.union` ftv t2 45 | 46 | instance Substitutable a => Substitutable [a] where 47 | apply = map . apply 48 | ftv = foldr (Set.union . ftv) Set.empty 49 | 50 | instance Substitutable Env where 51 | apply s (TypeEnv env) = TypeEnv $ Map.map (apply s) env 52 | ftv (TypeEnv env) = ftv $ Map.elems env 53 | -------------------------------------------------------------------------------- /src/MicroML/Typing/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | module MicroML.Typing.Type where 4 | 5 | newtype TVar = TV String 6 | deriving (Show, Eq, Ord) 7 | 8 | data Type 9 | = TVar TVar 10 | | TCon String 11 | | TArrow Type Type 12 | deriving (Show, Eq, Ord) 13 | 14 | data TypeScheme = Forall [TVar] Type 15 | deriving (Show, Eq, Ord) 16 | 17 | typeNum = TCon "Number" 18 | typeBool = TCon "Boolean" 19 | typeString = TCon "String" 20 | typeChar = TCon "Char" 21 | typeError = TCon "Error" 22 | typeNil = TVar $ TV "[a]" 23 | -------------------------------------------------------------------------------- /src/MicroML/Typing/TypeError.hs: -------------------------------------------------------------------------------- 1 | module MicroML.Typing.TypeError where 2 | 3 | import MicroML.Typing.Type 4 | import MicroML.Syntax 5 | 6 | type Constraint = (Type, Type) 7 | 8 | data TypeError 9 | = UnificationFail Type Type 10 | | InfiniteType TVar Type 11 | | UnboundVariable String 12 | | Ambigious [Constraint] 13 | | UnificationMismatch [Type] [Type] 14 | | UnsupportedOperation String 15 | | BadArg Expr String 16 | -------------------------------------------------------------------------------- /src/Repl/Eval.hs: -------------------------------------------------------------------------------- 1 | module Repl.Eval where 2 | 3 | import MicroML.Syntax 4 | import MicroML.ListPrimitives 5 | import MicroML.MathsPrimitives 6 | 7 | import qualified Data.Map as Map 8 | import Data.Maybe (fromJust) 9 | 10 | emptyTmenv :: TermEnv 11 | emptyTmenv = Map.empty 12 | 13 | -- | main eval function for the repl 14 | eval :: TermEnv -> Expr -> Expr 15 | eval env expr = case expr of 16 | num@(Lit (LInt _)) -> num 17 | doub@(Lit (LDouble _)) -> doub 18 | char@(Lit (LChar _)) -> char 19 | str@(Lit (LString _)) -> str 20 | bool@(Lit (LBoolean _)) -> bool 21 | tup@(Lit (LTup _)) -> tup 22 | ls@(List _) -> ls 23 | Nil -> Nil 24 | Var x -> fromJust (Map.lookup x env) -- the type checker ensures we never get this far 25 | FixPoint e -> eval env (App e (FixPoint e)) 26 | Lam x body -> Closure x body env 27 | App a b -> do 28 | let Closure n expr' clo = eval env a 29 | let arg = eval env b 30 | let new' = Map.insert n arg clo 31 | eval new' expr' 32 | If cond tr fls -> do 33 | let cond' = eval env cond 34 | if cond' == Lit (LBoolean True) 35 | then eval env tr 36 | else eval env fls 37 | Let x e body -> do 38 | let e' = eval env e 39 | let new' = Map.insert x e' env 40 | eval new' body 41 | UnaryOp op a -> do 42 | let a' = eval env a 43 | case op of 44 | Show -> show' a' 45 | Read -> read' a' 46 | Car -> car a' 47 | Cdr -> cdr a' 48 | OpLog -> log' a' 49 | Chr -> chr' a' 50 | Ord -> ord' a' 51 | Minus -> case a' of 52 | (Lit (LInt x)) -> Lit . LInt $ negate x 53 | (Lit (LDouble x)) -> Lit . LDouble $ negate x 54 | Not -> case a' of 55 | (Lit (LBoolean True)) -> Lit . LBoolean $ False 56 | (Lit (LBoolean False)) -> Lit . LBoolean $ True 57 | BinOp op a b -> do 58 | let a' = eval env a 59 | let b' = eval env b 60 | case op of 61 | OpEnum -> enumFromTo_ a' b' 62 | OpAdd -> a' `add` b' 63 | OpSub -> a' `sub` b' 64 | OpMul -> a' `mul` b' 65 | OpDiv -> a' `div'` b' 66 | OpIntDiv -> a' `intDiv` b' 67 | OpMod -> a' `mod'` b' 68 | OpExp -> a' `exp'` b' 69 | OpOr -> a' `or'` b' 70 | OpAnd -> a' `and'` b' 71 | OpXor -> a' `xor'` b' 72 | OpEq -> a' `opEq` b' 73 | OpLe -> a' `opLe` b' 74 | OpLt -> a' `opLt` b' 75 | OpGe -> a' `opGe` b' 76 | OpGt -> a' `opGt` b' 77 | OpNotEq -> a' `opNotEq` b' 78 | OpCons -> a' `cons` b' 79 | OpAppend -> eval env (a' `append` b') 80 | OpPipe -> eval env (App b a) 81 | 82 | runEval :: TermEnv -> String -> Expr -> (Expr, TermEnv) 83 | runEval env x exp = 84 | let res = eval env exp 85 | in (res, Map.insert x res env) 86 | -------------------------------------------------------------------------------- /src/Repl/Help.hs: -------------------------------------------------------------------------------- 1 | -- | A very limited pseudo-markdown parser for pretty printing the help information to the terminal 2 | -- in interactive sessions 3 | -- 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Repl.Help where 7 | 8 | import Control.Monad (void) 9 | 10 | import Text.Parsec 11 | import Text.Parsec.Text.Lazy 12 | import Text.PrettyPrint 13 | 14 | import qualified Data.Text.Lazy as L 15 | 16 | data Markdown = 17 | Emphasis String 18 | | Header String 19 | | Plain String 20 | | Background String 21 | | Underline String 22 | deriving (Eq, Show) 23 | 24 | funcChars :: Parser Char 25 | funcChars = oneOf " '?:+<>-=)!.(][,;\"\n" 26 | 27 | funcName :: Parser String 28 | funcName = do 29 | void $ string "==" 30 | st <- many1 $ alphaNum <|> oneOf "?'_ " 31 | void $ string "==" 32 | return st 33 | 34 | comments :: Parser String 35 | comments = do 36 | void $ string "let" <|> string "--" 37 | -- <|> string "\n" 38 | void $ anyChar `manyTill` newline 39 | return "" 40 | 41 | header :: Parser Markdown 42 | header = do 43 | void $ many1 $ string "#" 44 | st <- many1 (alphaNum <|> funcChars "header") 45 | void $ many1 $ string "#" 46 | return $ Header st 47 | 48 | emph :: Parser Markdown 49 | emph = do 50 | void $ string "**" 51 | st <- many1 (alphaNum <|> funcChars) 52 | void $ string "**" 53 | return $ Emphasis st 54 | 55 | background :: Parser Markdown 56 | background = do 57 | void $ string "***" 58 | st <- many1 (alphaNum <|> funcChars) 59 | void $ string "***" 60 | return $ Background st 61 | 62 | underline :: Parser Markdown 63 | underline = do 64 | void $ string "__" 65 | st <- many1 $ alphaNum <|> funcChars 66 | void $ string "__" 67 | return $ Underline st 68 | 69 | plain :: Parser Markdown 70 | plain = do 71 | st <- many1 (alphaNum <|> funcChars) 72 | return $ Plain st 73 | 74 | helpStyle :: Parser Markdown 75 | helpStyle = header 76 | <|> try background 77 | <|> try emph 78 | <|> underline 79 | <|> plain 80 | "markdown syntax" 81 | 82 | type HelpBlock = (String, [Markdown]) 83 | 84 | helpModl :: Parser HelpBlock 85 | helpModl = do 86 | void $ string "(*" <* spaces 87 | name <- spaces *> funcName <* spaces 88 | helpBlock <- many helpStyle <* spaces 89 | void $ spaces *> string "*)" <* spaces 90 | skipMany (try comments) 91 | return (name, helpBlock) 92 | 93 | allHelp :: Parser [HelpBlock] 94 | allHelp = do 95 | skipMany comments 96 | sepEndBy1 helpModl (skipMany (comments <|> string "\n")) 97 | 98 | parseHelp :: SourceName -> L.Text -> Either ParseError [HelpBlock] 99 | parseHelp = parse allHelp 100 | 101 | prettyPrint :: Markdown -> Doc 102 | prettyPrint st = 103 | case st of 104 | (Emphasis s) -> text "\ESC[1m" <> text s <> text "\ESC[0m" 105 | (Plain s) -> text s 106 | (Header s) -> text "\ESC[1;31m" <> text s <> "\ESC[0m" 107 | (Background s) -> text "\ESC[1;43;30m" <> text " " <> text s <> text " " <> text "\ESC[0m" 108 | (Underline s) -> text "\ESC[4m" <> text s <> text "\ESC[0m" 109 | 110 | renderHelp :: [Markdown] -> String 111 | renderHelp = concatMap (render . prettyPrint) 112 | -------------------------------------------------------------------------------- /src/Repl/HelpEnv.hs: -------------------------------------------------------------------------------- 1 | module Repl.HelpEnv where 2 | 3 | import qualified Data.Map as Map 4 | import Repl.Help 5 | 6 | data HelpEnv = HEnv { unHelp :: Map.Map String [Markdown] } 7 | deriving (Eq, Show) 8 | 9 | empty :: HelpEnv 10 | empty = HEnv Map.empty 11 | 12 | lookup :: String -> HelpEnv -> Maybe [Markdown] 13 | lookup k (HEnv env) = Map.lookup k env 14 | 15 | extend :: HelpEnv -> (String, [Markdown]) -> HelpEnv 16 | extend env (var, ts) = env { unHelp = Map.insert var ts (unHelp env) } 17 | 18 | merge :: HelpEnv -> HelpEnv -> HelpEnv 19 | merge (HEnv a) (HEnv b) = HEnv (Map.union a b) 20 | 21 | instance Monoid HelpEnv where 22 | mempty = empty 23 | mappend = merge 24 | -------------------------------------------------------------------------------- /src/Repl/ParseTree.hs: -------------------------------------------------------------------------------- 1 | module Repl.ParseTree (showTree) where 2 | 3 | import Data.Tree 4 | import Data.Tree.Pretty 5 | 6 | import MicroML.Syntax 7 | 8 | -- | pretty print the parse tree of an expression in the repl 9 | 10 | exprToTree :: (String, Expr) -> Tree String 11 | exprToTree (nm, ex) = 12 | Node nm $ etoT ex 13 | 14 | etoT :: Expr -> [Tree Name] 15 | etoT (FixPoint e1) = [Node "rec" (etoT e1)] 16 | etoT Nil = [Node "[]" []] 17 | etoT (App e1 e2) = etoT e1 ++ etoT e2 18 | etoT (UnaryOp op e1) = [Node (ppUnop op) (etoT e1)] 19 | etoT (If cond tr fls) = [Node "if" (etoT cond ++ etoT tr ++ etoT fls)] 20 | etoT (Var x) = [Node x []] 21 | etoT (Let nm e1 e2) = [Node nm (etoT e1 ++ etoT e2)] 22 | etoT (Lit (LInt x)) = [Node (show x) []] 23 | etoT (Lit (LDouble x)) = [Node (show x) []] 24 | etoT (Lit (LChar x)) = [Node (show x) []] 25 | etoT (Lit (LString x)) = [Node x []] 26 | etoT (Lit (LBoolean x)) = [Node (show x) []] 27 | etoT (Lit (LTup x)) = [Node (show x) []] 28 | etoT (PrimitiveErr _) = [Node "error" []] 29 | etoT (Lam nm ex) = [Node nm $ etoT ex] 30 | etoT (BinOp op e1 e2) = [Node (pp op) (etoT e1 ++ etoT e2)] 31 | etoT x = [Node (show x) []] 32 | 33 | ppUnop :: UnaryOp -> String 34 | ppUnop OpLog = "log" 35 | ppUnop Car = "head" 36 | ppUnop Cdr = "tail" 37 | ppUnop Read = "read" 38 | ppUnop Show = "show" 39 | ppUnop Not = "not" 40 | ppUnop Minus = "-" 41 | ppUnop Chr = "char" 42 | ppUnop Ord = "ord" 43 | 44 | pp :: Binop -> String 45 | pp OpAdd = "+" 46 | pp OpMul = "*" 47 | pp OpEq = "==" 48 | pp OpAppend = "++" 49 | pp OpNotEq = "≠" 50 | pp OpOr = "or" 51 | pp OpExp = "^" 52 | pp OpDiv = "÷" 53 | pp OpIntDiv = "÷" 54 | pp OpPipe = ">>" 55 | pp OpMod = "%" 56 | pp OpAnd = "and" 57 | pp OpXor = "xor" 58 | pp OpSub = "-" 59 | pp OpLe = "<=" 60 | pp OpLt = "<" 61 | pp OpGe = ">=" 62 | pp OpGt = ">" 63 | pp OpCons = ":" 64 | 65 | showTree :: (String, Expr) -> IO () 66 | showTree tr = putStrLn $ drawVerticalTreeWith 5 (exprToTree tr) 67 | -------------------------------------------------------------------------------- /src/Repl/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language FlexibleInstances #-} 2 | {-# Language TypeSynonymInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Repl.Pretty where 7 | 8 | import MicroML.Typing.Type 9 | import MicroML.Syntax 10 | import MicroML.Typing.Env 11 | import MicroML.Typing.TypeError 12 | import MicroML.Config 13 | 14 | import qualified Data.Map as Map 15 | import Data.List (intercalate) 16 | import Data.List.Split (splitOn) 17 | import Text.PrettyPrint 18 | 19 | parensIf :: Bool -> Doc -> Doc 20 | parensIf True = parens 21 | parensIf False = id 22 | 23 | class Pretty p where 24 | ppr :: Int -> p -> Doc 25 | 26 | {-instance Pretty Name where-} 27 | {-ppr _ = text -} 28 | 29 | instance Pretty TVar where 30 | ppr _ (TV x) = text x 31 | 32 | instance Pretty Type where 33 | ppr p (TArrow a b) = parensIf (isArrow a) (ppr p a) <+> text pbold <+> "→" <+> text clear <+> ppr p b 34 | where 35 | isArrow TArrow{} = True 36 | isArrow _ = False 37 | ppr p (TVar a) = ppr p a 38 | ppr _ (TCon "Number") = text "Number" 39 | ppr _ (TCon "String") = text "String" 40 | ppr _ (TCon "Boolean") = text "Boolean" 41 | ppr _ (TCon "Char") = text "Char" 42 | ppr _ (TCon t1) = text $ opening ++ last ty ++ closing 43 | where ty = splitOn " " t1 44 | opening = concat $ replicate (length ty - 1) "[" 45 | closing = concat $ replicate (length ty - 1) "]" 46 | 47 | instance Pretty TypeScheme where 48 | ppr p (Forall [] t) = ppr p t 49 | ppr p (Forall ts t) = text "for all" <+> hcat (punctuate space (map (ppr p) ts)) <> text "." <+> ppr p t 50 | 51 | instance Pretty Expr where 52 | ppr _ Closure{} = text "<>" 53 | ppr _ (Lit (LInt i)) = integer i 54 | ppr _ (Lit (LDouble d)) = double d 55 | ppr _ (Lit (LString str)) = doubleQuotes $ text str 56 | ppr _ (Lit (LChar c)) = quotes $ text [c] -- convert char to a string 57 | ppr _ (Lit (LBoolean True)) = text "true" 58 | ppr _ (Lit (LBoolean False)) = text "false" 59 | ppr _ Nil = text "empty list" 60 | ppr _ ls@(BinOp OpCons _ _) = text $ ppList ls 61 | ppr _ (Lit (LTup xs)) = text $ "{" ++ intercalate ", " (map ppexpr xs) ++ "}" 62 | ppr _ (List xs) = text $ "[" ++ ppList xs ++ "]" 63 | ppr _ xs = text $ show xs 64 | 65 | instance Show TypeError where 66 | show (UnificationFail a b) = 67 | concat ["Cannot ", "\ESC[33mmatch\ESC[0m", " expected type ", pptype a, " with actual type ", pptype b] 68 | show (InfiniteType (TV a) b) = 69 | concat ["Cannot construct the ", "infinite type", ": ", a, " = ", pptype b] 70 | show (UnboundVariable a) = "Not in scope: " ++ bold ++ a ++ clear 71 | show (UnsupportedOperation a) = bold ++ a ++ clear 72 | show (UnificationMismatch a b) = show a ++ show b 73 | show (BadArg a s) = ppexpr a ++ s 74 | 75 | ppscheme :: TypeScheme -> String 76 | ppscheme = render . ppr 0 77 | 78 | pptype :: Type -> String 79 | pptype = render . ppr 0 80 | 81 | ppList :: Expr -> String 82 | ppList (List xs) = "[" ++ ppList xs ++ "]" 83 | ppList (BinOp OpCons x Nil) = ppList x 84 | ppList (BinOp OpCons Nil (BinOp OpCons x xs)) = ppList x ++ ppList xs 85 | ppList (BinOp OpCons x xs) = ppList x ++ ", " ++ ppList xs 86 | ppList l@Lit{} = 87 | case l of 88 | Lit (LInt n) -> show n 89 | Lit (LDouble n) -> show n 90 | Lit (LString n) -> show n 91 | Lit (LChar n) -> show n 92 | tup@(Lit (LTup _)) -> ppexpr tup 93 | Lit (LBoolean True) -> "true" 94 | Lit (LBoolean False) -> "false" 95 | ppList x = show x 96 | 97 | ppexpr :: Expr -> String 98 | ppexpr = render . ppr 0 99 | 100 | ppsig :: (Expr, TypeScheme) -> ConfigEnv -> String 101 | ppsig (a, b) conf = getColour conf "bold" ++ ppexpr a ++ clear ++ " : " ++ ppscheme b 102 | 103 | ppsig' :: ConfigEnv -> (String, TypeScheme) -> String 104 | ppsig' conf (a, b) = getColour conf "bold" ++ a ++ clear ++ " : " ++ ppscheme b 105 | 106 | ppenv :: Env -> ConfigEnv -> [String] 107 | ppenv (TypeEnv env) conf = map (ppsig' conf) (Map.toList env) 108 | 109 | pbold :: String 110 | pbold = "\ESC[37m" 111 | -------------------------------------------------------------------------------- /src/Repl/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Repl.Repl where 7 | 8 | import MicroML.Config 9 | import Repl.Eval 10 | import Repl.HelpEnv 11 | import qualified Repl.HelpEnv as HE 12 | import Repl.Pretty 13 | import Repl.ParseTree 14 | import Repl.Help 15 | 16 | import MicroML.Syntax as S 17 | import MicroML.Parser 18 | import MicroML.Lexer hiding (contents) 19 | import MicroML.Typing.Env as Env 20 | import MicroML.Typing.Infer 21 | 22 | import qualified Data.Map as Map 23 | import qualified Data.Text.Lazy as L 24 | import qualified Data.Text.Lazy.IO as L 25 | import Data.List (isPrefixOf, foldl') 26 | import qualified Data.ConfigFile as DC 27 | import Data.Either.Utils 28 | import Data.Maybe (fromJust) 29 | 30 | import Control.Monad.State.Strict 31 | import Control.Exception 32 | 33 | import System.IO 34 | import System.Exit 35 | import System.Directory 36 | import System.FilePath 37 | import System.Console.Repline 38 | import qualified System.Process as S 39 | 40 | ----------- 41 | -- Types -- 42 | ----------- 43 | 44 | data IState = IState 45 | { typeEnv :: Env -- Type environment 46 | , termEnv :: TermEnv -- Value environment 47 | , helpEnv :: HelpEnv -- Help environment 48 | , configEnv :: ConfigEnv -- Config environment 49 | } 50 | 51 | initState :: IState 52 | initState = IState Env.microbit emptyTmenv HE.empty configEmpty 53 | 54 | type Repl a = HaskelineT (StateT IState IO) a 55 | 56 | hoistError :: (Show a1) => ConfigEnv -> Either a1 a -> Repl a 57 | hoistError _ (Right val) = return val 58 | hoistError conf (Left err) = do 59 | liftIO $ putStrLn $ putColour conf $ show err 60 | abort 61 | 62 | evalDef :: TermEnv -> (String, Expr) -> TermEnv 63 | evalDef env (nm, ex) = termEnv' 64 | where (_, termEnv') = runEval env nm ex 65 | 66 | -- read the help info into a dictionary 67 | toHelpenv :: [HelpBlock] -> HelpEnv 68 | toHelpenv ls = HEnv $ Map.fromList ls 69 | 70 | -- | execution function while repl is running 71 | exec :: Bool -> L.Text -> Repl () 72 | exec update source = do 73 | st <- get 74 | 75 | mod' <- hoistError (configEnv st) $ parseProgram "" source 76 | typeEnv' <- hoistError (configEnv st) $ inferTop (typeEnv st) mod' 77 | 78 | let st' = st { termEnv = foldl' evalDef (termEnv st) mod' 79 | , typeEnv = typeEnv' `mappend` typeEnv st 80 | } 81 | 82 | when update (put st') 83 | 84 | case Prelude.lookup "it" mod' of 85 | Nothing -> return () 86 | Just ex -> do 87 | let (val, _) = runEval (termEnv st') "it" ex 88 | showOutput val st' 89 | 90 | -- | execution function for initial loading 91 | -- TODO: a lot of code repetition here, should be merged with exec 92 | exec' :: L.Text -> Repl () 93 | exec' source = do 94 | st <- get 95 | 96 | mod' <- hoistError (configEnv st) $ parseProgram "" source 97 | typeEnv' <- hoistError (configEnv st) $ inferTop (typeEnv st) mod' 98 | helpEnv' <- hoistError (configEnv st) $ parseHelp "" source 99 | 100 | let st' = st { termEnv = foldl' evalDef (termEnv st) mod' 101 | , typeEnv = typeEnv' `mappend` typeEnv st 102 | , helpEnv = toHelpenv helpEnv' `mappend` helpEnv st 103 | } 104 | put st' 105 | 106 | showOutput :: Expr -> IState -> Repl () 107 | showOutput arg st = 108 | case Env.lookup "it" (typeEnv st) of 109 | Just val -> liftIO $ putStrLn $ putColour (configEnv st) $ ppsig (arg, val) (configEnv st) 110 | Nothing -> return () 111 | 112 | cmd :: String -> Repl () 113 | cmd source = exec True (L.pack source) 114 | 115 | -------------- 116 | -- Commands -- 117 | -------------- 118 | 119 | -- | view the parse tree of an expression in the repl 120 | -- :pst command 121 | pst :: [String] -> Repl () 122 | pst expr = do 123 | st <- get 124 | tree <- hoistError (configEnv st) $ parseProgram "" $ L.pack $ concatMap (++ " ") expr 125 | let tyEnv = inferTop (typeEnv st) tree 126 | case tyEnv of 127 | Left err -> liftIO . print $ err 128 | Right _ -> liftIO . showTree . head $ tree 129 | 130 | pstText :: [String] -> Repl () 131 | pstText expr = do 132 | st <- get 133 | tree <- hoistError (configEnv st) $ parseProgram "" $ L.pack $ concatMap (++ " ") expr 134 | let tyEnv = inferTop (typeEnv st) tree 135 | case tyEnv of 136 | Left err -> liftIO . print $ err 137 | Right _ -> do 138 | liftIO . putStrLn $ "The parsetree of " ++ bold ++ (fst . head) tree ++ S.clear ++ " is: " 139 | liftIO . putStrLn $ show . snd . head $ tree 140 | 141 | -- :browse command 142 | browse :: [String] -> Repl () 143 | browse _ = do 144 | st <- get 145 | liftIO $ mapM_ (putStrLn . putColour (configEnv st)) $ ppenv (typeEnv st) (configEnv st) 146 | 147 | help :: [String] -> Repl () 148 | help args = 149 | if null args 150 | then liftIO $ putStrLn "you haven't entered a function" 151 | else do st <- get 152 | let arg = unwords args 153 | case HE.lookup arg (helpEnv st) of 154 | Just val -> liftIO $ putStr $ "\n" ++ renderHelp val ++ "\n" 155 | Nothing -> liftIO $ putStrLn $ "there is no help available for " ++ arg ++ " (:" 156 | 157 | -- :using command 158 | -- this is only for files kept in the standard library 159 | using :: [String] -> Repl () 160 | using args = 161 | if null args 162 | then liftIO $ putStrLn "you must enter a library name!" 163 | else do dir <- liftIO getHomeDirectory 164 | let stdlib = dir ".microML/" 165 | exists <- liftIO $ doesDirectoryExist stdlib 166 | if exists 167 | then do 168 | let safe = fst (splitExtension $ unwords args) ++ ".mml" 169 | tr <- liftIO $ doesFileExist $ stdlib ++ safe 170 | if tr 171 | then do 172 | contents <- liftIO $ L.readFile $ stdlib ++ safe 173 | exec' contents 174 | else liftIO . putStrLn $ "the file " ++ unwords args ++ " does not exist" 175 | else error "Error: Unable to locate standard library in the home directory" 176 | 177 | -- :load command 178 | load :: [String] -> Repl () 179 | load args = 180 | if null args 181 | then liftIO $ putStrLn "you must enter a filename" 182 | else do 183 | tr <- liftIO $ doesFileExist (unwords args) 184 | if tr then do 185 | contents <- liftIO $ L.readFile (unwords args) 186 | exec True contents 187 | else liftIO $ putStrLn "the file does not exist" 188 | 189 | -- :type command 190 | typeof :: [String] -> Repl () 191 | typeof args = 192 | if null args 193 | then liftIO $ putStrLn "you must enter the name of a function" 194 | else do 195 | st <- get 196 | let arg = unwords args 197 | case Env.lookup arg (typeEnv st) of 198 | Just val -> liftIO $ putStrLn $ putColour (configEnv st) $ ppsig' (configEnv st) (arg, val) 199 | Nothing -> liftIO $ putStrLn $ "microML: " ++ show arg ++ " is not in scope" 200 | 201 | -- :quit command 202 | quit :: a -> Repl () 203 | quit _ = liftIO exitSuccess 204 | 205 | -- :clear 206 | clear :: a -> Repl () 207 | clear _ = liftIO $ S.callCommand "clear" 208 | 209 | -- :! access the shell, errors are wrapped in an IOException 210 | sh :: [String] -> Repl () 211 | sh arg = liftIO $ 212 | catch (S.callCommand (unwords arg)) 213 | (\e -> do let err = show (e :: IOException) 214 | hPutStr stderr ("Warning: Couldn't run " ++ unwords arg ++ " " ++ err ++ "\n") 215 | return ()) 216 | 217 | ----------------------- 218 | -- Interactive Shell -- 219 | ----------------------- 220 | 221 | -- Prefix tab completer 222 | defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] 223 | defaultMatcher = [ 224 | (":load" , fileCompleter) 225 | ] 226 | 227 | -- Default tab completer 228 | comp :: (Monad m, MonadState IState m) => WordCompleter m 229 | comp n = do 230 | let cmds = [":using", ":type", ":browse", ":quit", ":!", ":help", ":?", ":pst", ":clear", ":load", ":pstText"] 231 | Env.TypeEnv ctx <- gets typeEnv 232 | let defs = Map.keys ctx 233 | let builtins = reservedNames 234 | return $ filter (isPrefixOf n) (cmds ++ defs ++ builtins) 235 | 236 | options :: [(String, [String] -> Repl ())] 237 | options = [ 238 | ("using" , using) 239 | , ("browse" , browse) 240 | , ("quit" , quit) 241 | , ("type" , typeof) 242 | , ("!" , sh) 243 | , ("clear" , Repl.Repl.clear) 244 | , ("?" , help) 245 | , ("help" , help) -- alternative 246 | , ("pst" , pst) -- view parse tree of a given expression 247 | , ("pstText", pstText) 248 | , ("load" , load) 249 | ] 250 | 251 | ----------------- 252 | -- Entry Point -- 253 | ----------------- 254 | 255 | completer :: CompleterStyle (StateT IState IO) 256 | completer = Prefix (wordCompleter comp) defaultMatcher 257 | 258 | prompt :: String 259 | prompt = "\ESC[33mmicroML ⊦ " ++ S.clear 260 | 261 | getBanner :: Repl () 262 | getBanner = do 263 | _ <- liftIO $ S.system "figlet -f $(ls /usr/share/figlet/fonts/*.flf |shuf -n1) \"microML\"\ 264 | \| cowsay -n -f $(ls /usr/share/cows | shuf -n1) | lolcat" 265 | return () 266 | 267 | standardBanner :: String 268 | standardBanner = "\ESC[1;31m" ++ 269 | " _ ___ ___ _ \n" ++ 270 | " (_) | \\/ || | \n" ++ 271 | " _ __ ___ _ ___ _ __ ___ | . . || | \ESC[33;1mversion 0.05\ESC[1;31m\n" ++ 272 | " | '_ ` _ \\| |/ __| '__/ _ \\| |\\/| || | \ESC[33;1mfor help type :? or :help\ESC[1;31m\n" ++ 273 | " | | | | | | | (__| | | (_) | | | || |____ \n" ++ 274 | " |_| |_| |_|_|\\___|_| \\___/\\_| |_/\\_____/ \ESC[0m" 275 | 276 | -- | initialize the repl environment. Look for the dependencies for the fancy banner, and if not, 277 | -- use the boring standard one. 278 | ini :: Repl () 279 | ini = do 280 | fig <- liftIO $ findExecutable "figlet" 281 | cow <- liftIO $ findExecutable "cowsay" 282 | lol <- liftIO $ findExecutable "lolcat" 283 | if not (null fig) && not (null cow) && not (null lol) 284 | then do 285 | using ["standard"] 286 | liftIO $ putStrLn "\n\ESC[1mWelcome to microML\ESC[0m\t\t\t\ESC[33;1mversion 0.05\ESC[1;31m\n" 287 | getBanner 288 | liftIO $ putStrLn "\n\n" 289 | getConfig 290 | else do 291 | using ["standard"] 292 | liftIO $ putStrLn $ standardBanner ++ "\n\n" ++ bold ++ "Welcome to microML" ++ S.clear ++ "\n\n" 293 | getConfig 294 | 295 | -- | reads the config file (if it exists) and stores it in the global state 296 | -- also queries terminfo for max colours supported 297 | getConfig :: Repl () 298 | getConfig = do 299 | home <- liftIO getHomeDirectory 300 | let file = home ".microMLrc" 301 | exists <- liftIO $ doesFileExist file 302 | if exists 303 | then do 304 | st <- get 305 | conf <- liftIO $ DC.readfile DC.emptyCP file 306 | let cp = forceEither conf 307 | let config = forceEither $ DC.items cp "colourscheme" 308 | c <- liftIO maxColours 309 | let term = show $ fromJust c 310 | let config' = config ++ [("term", term)] 311 | let escaped = escape config' term 312 | let st' = st { configEnv = Map.fromList escaped `mappend` configEnv st } 313 | put st' 314 | else error "Error: no configuration file found" 315 | 316 | -- | main function for the repl 317 | shell :: IO () 318 | shell = flip evalStateT initState $ evalRepl prompt cmd options completer ini 319 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: 2 | semigroups: 3 | bytestring-builder: false 4 | extra-package-dbs: [] 5 | packages: 6 | - '.' 7 | extra-deps: 8 | - ConfigFile-1.1.4 9 | - HUnit-1.3.1.1 10 | - MissingH-1.4.0.1 11 | - MonadRandom-0.4.2.3 12 | - QuickCheck-2.9.1 13 | - StateVar-1.1.0.4 14 | - ansi-terminal-0.6.2.3 15 | - async-2.1.0 16 | - attoparsec-0.13.0.2 17 | - base-orphans-0.5.4 18 | - bifunctors-5.4.1 19 | - boxes-0.1.4 20 | - cmdargs-0.10.14 21 | - comonad-5 22 | - contravariant-1.4 23 | - distributive-0.5.0.2 24 | - either-4.4.1.1 25 | - errors-2.1.2 26 | - exceptions-0.8.3 27 | - free-4.12.4 28 | - hashable-1.2.4.0 29 | - hslogger-1.2.10 30 | - hspec-2.2.3 31 | - hspec-core-2.2.3 32 | - hspec-discover-2.2.3 33 | - hspec-expectations-0.7.2 34 | - mmorph-1.0.6 35 | - monad-control-1.0.1.0 36 | - mtl-2.2.1 37 | - network-2.6.3.1 38 | - old-locale-1.0.0.7 39 | - old-time-1.1.0.3 40 | - parsec-3.1.11 41 | - prelude-extras-0.4.0.3 42 | - pretty-tree-0.1.0.0 43 | - primitive-0.6.1.0 44 | - profunctors-5.2 45 | - quickcheck-io-0.1.3 46 | - random-1.1 47 | - regex-base-0.93.2 48 | - regex-compat-0.95.1 49 | - regex-posix-0.95.2 50 | - repline-0.1.5.0 51 | - safe-0.3.9 52 | - scientific-0.3.4.9 53 | - semigroupoids-5.1 54 | - semigroups-0.18.2 55 | - setenv-0.1.1.3 56 | - split-0.2.3.1 57 | - stm-2.4.4.1 58 | - tagged-0.8.5 59 | - terminfo-hs-0.2.1 60 | - text-1.2.2.1 61 | - tf-random-0.5 62 | - transformers-base-0.4.4 63 | - transformers-compat-0.5.1.4 64 | - unexceptionalio-0.3.0 65 | - unordered-containers-0.2.7.1 66 | - vector-0.11.0.0 67 | - void-0.7.1 68 | resolver: ghc-7.10.3 69 | -------------------------------------------------------------------------------- /test/CallGraphSpec.hs: -------------------------------------------------------------------------------- 1 | module CallGraphSpec where 2 | 3 | import Test.Hspec 4 | import MicroML.Syntax 5 | import Compiler.CallGraph 6 | import Control.Exception (evaluate) 7 | 8 | callGraph :: IO () 9 | callGraph = hspec $ 10 | describe "callGraph" $ do 11 | describe "checkForDuplicates" $ do 12 | it "should do nothing to a list with no duplicates" $ 13 | checkForDuplicates [("test1", Lit (LInt 1)), ("test2", Lit (LInt 1))] `shouldBe` [("test1", Lit (LInt 1)), ("test2", Lit (LInt 1))] 14 | it "should throw an error if there are duplicates" $ 15 | evaluate (checkForDuplicates [("test", Lit (LInt 1)), ("test", Lit (LInt 1))]) `shouldThrow` anyException 16 | 17 | 18 | describe "reachableFromMain" $ do 19 | it "should throw an error if not every function is reachable" $ 20 | evaluate (reachableFromMain [("main", Var "single"), ("double", Lit (LInt 1))]) `shouldThrow` anyException 21 | it "should return the list unchanged if it's fully connected from main" $ 22 | reachableFromMain [("main", Var "double"), ("double", Lit (LInt 1))] `shouldBe` [("main", Var "double"), ("double", Lit (LInt 1))] 23 | 24 | 25 | -------------------------------------------------------------------------------- /test/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | module EvalSpec where 2 | 3 | import Test.Hspec 4 | import Repl.Eval 5 | import MicroML.Syntax 6 | import Control.Exception (evaluate) 7 | 8 | evalspec :: IO () 9 | evalspec = hspec $ 10 | describe "evalspec" $ do 11 | describe "eval" $ do 12 | it "should eval an int to an int" $ 13 | eval emptyTmenv (Lit (LInt 1)) `shouldBe` Lit (LInt 1) 14 | it "should eval a double to a double" $ 15 | eval emptyTmenv (Lit (LDouble 1.0)) `shouldBe` Lit (LDouble 1.0) 16 | it "should eval a char to a char" $ 17 | eval emptyTmenv (Lit (LChar 'a')) `shouldBe` Lit (LChar 'a') 18 | it "should eval a string to a string" $ 19 | eval emptyTmenv (Lit (LString "hello")) `shouldBe` Lit (LString "hello") 20 | it "should eval a bool to a bool" $ 21 | eval emptyTmenv (Lit (LBoolean True)) `shouldBe` Lit (LBoolean True) 22 | it "should eval Nil to Nil" $ 23 | eval emptyTmenv Nil `shouldBe` Nil 24 | -------------------------------------------------------------------------------- /test/ListPrimitivesSpec.hs: -------------------------------------------------------------------------------- 1 | module ListPrimitivesSpec where 2 | 3 | import Test.Hspec 4 | import MicroML.ListPrimitives 5 | import MicroML.Syntax 6 | import Control.Exception (evaluate) 7 | 8 | listprims :: IO () 9 | listprims = hspec $ 10 | describe "listprims" $ do 11 | describe "car" $ do 12 | it "gets the head of a list" $ 13 | car (BinOp OpCons (Lit (LInt 3)) Nil) `shouldBe` (Lit (LInt 3) :: Expr) 14 | it "gets the head of a string" $ 15 | car (Lit (LString "hello")) `shouldBe` (Lit (LChar 'h') :: Expr) 16 | it "should fail on non-list ints" $ 17 | evaluate (car (Lit (LInt 1))) `shouldThrow` anyException 18 | it "should fail on non-list doubles" $ 19 | evaluate (car (Lit (LDouble 1))) `shouldThrow` anyException 20 | it "should fail on non-list chars" $ 21 | evaluate (car (Lit (LChar 'a'))) `shouldThrow` anyException 22 | it "should fail on non-list bools" $ 23 | evaluate (car (Lit (LBoolean True))) `shouldThrow` anyException 24 | 25 | describe "cdr" $ do 26 | it "gets the tail of a string" $ 27 | cdr (BinOp OpCons (Lit (LInt 1)) (BinOp OpCons (Lit (LInt 2)) Nil)) `shouldBe` ((BinOp OpCons (Lit (LInt 2)) Nil) :: Expr) 28 | it "gets the tail of a string" $ 29 | cdr (Lit (LString "hello")) `shouldBe` (Lit (LString "ello") :: Expr) 30 | it "should fail on non-list ints" $ 31 | evaluate (cdr (Lit (LInt 1))) `shouldThrow` anyException 32 | it "should fail on non-list doubles" $ 33 | evaluate (cdr (Lit (LDouble 1))) `shouldThrow` anyException 34 | it "should fail on non-list chars" $ 35 | evaluate (cdr (Lit (LChar 'a'))) `shouldThrow` anyException 36 | it "should fail on non-list bools" $ 37 | evaluate (cdr (Lit (LBoolean True))) `shouldThrow` anyException 38 | 39 | describe "append" $ do 40 | it "joins string literals" $ 41 | append (Lit (LString "hello ")) (Lit (LString "there")) `shouldBe` Lit (LString "hello there") 42 | it "joins lists" $ 43 | append (BinOp OpCons (Lit (LInt 1)) Nil) (BinOp OpCons (Lit (LInt 2)) Nil) `shouldBe` (BinOp OpCons (Lit (LInt 1)) (BinOp OpCons (Lit (LInt 2)) Nil) :: Expr) 44 | it "should fail on non-lists" $ 45 | append (Lit (LInt 1)) (Lit (LInt 2)) `shouldBe` (PrimitiveErr . ListPrim $ "Lit (LInt 1) Lit (LInt 2)") 46 | 47 | describe "show'" $ do 48 | it "returns a string from a string" $ 49 | show' (Lit (LString "hello")) `shouldBe` (Lit (LString "hello")) 50 | it "returns a string from an int" $ 51 | show' (Lit (LInt 1)) `shouldBe` (Lit (LString "1")) 52 | it "returns a string from a double" $ 53 | show' (Lit (LDouble 2.2)) `shouldBe` (Lit (LString "2.2")) 54 | it "returns a string from a char" $ 55 | show' (Lit (LChar 'c')) `shouldBe` (Lit (LString "c")) 56 | it "returns a string from a True boolean" $ 57 | show' (Lit (LBoolean True)) `shouldBe` (Lit (LString "true")) 58 | it "returns a string from a False boolean" $ 59 | show' (Lit (LBoolean False)) `shouldBe` (Lit (LString "false")) 60 | 61 | describe "read'" $ do 62 | it "takes a string and returns an integer" $ 63 | read' (Lit (LString "3")) `shouldBe` (Lit (LInt 3)) 64 | it "takes a string and returns an double" $ 65 | read' (Lit (LString "3.3")) `shouldBe` (Lit (LDouble 3.3)) 66 | it "should complain if passed a non-number string" $ 67 | read' (Lit (LString "dog")) `shouldBe` (PrimitiveErr $ ListPrim "the string does not contain a number") 68 | 69 | describe "ord'" $ do 70 | it "takes a char and returns an int" $ 71 | ord' (Lit (LChar 'a')) `shouldBe` (Lit (LInt 97)) 72 | 73 | describe "chr'" $ do 74 | it "takes an int and returns a char" $ 75 | chr' (Lit (LInt 97)) `shouldBe` (Lit (LChar 'a')) 76 | -------------------------------------------------------------------------------- /test/MathsPrimitives.hs: -------------------------------------------------------------------------------- 1 | module MathsPrimitives where 2 | 3 | import Test.Hspec 4 | import MicroML.ListPrimitives 5 | import MicroML.MathsPrimitives 6 | import MicroML.Syntax 7 | import Control.Exception (evaluate) 8 | 9 | mathsprims :: IO () 10 | mathsprims = hspec $ 11 | describe "mathsprims" $ do 12 | describe "add" $ do 13 | it "should add two integers" $ 14 | add (Lit (LInt 1)) (Lit (LInt 1)) `shouldBe` Lit (LInt 2) 15 | it "should add two doubles" $ 16 | add (Lit (LDouble 1.1)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 2.2) 17 | it "should add an int to a double" $ 18 | add (Lit (LInt 1)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 2.1) 19 | it "should add a double to an int" $ 20 | add (Lit (LDouble 1.1)) (Lit (LInt 1)) `shouldBe` Lit (LDouble 2.1) 21 | 22 | -- test for failure, but the type checker should prevent this ever happening 23 | it "should fail on other input" $ 24 | evaluate (add (Lit (LChar 'a')) (Lit (LChar 'a'))) `shouldThrow` anyException 25 | 26 | describe "sub" $ do 27 | it "should sub two integers" $ 28 | sub (Lit (LInt 1)) (Lit (LInt 1)) `shouldBe` Lit (LInt 0) 29 | it "should sub two doubles" $ 30 | sub (Lit (LDouble 1.1)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 0.0) 31 | it "should sub an int and a double" $ 32 | sub (Lit (LInt 2)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 0.9) 33 | it "should sub a double and an int" $ 34 | sub (Lit (LDouble 1.1)) (Lit (LInt 1)) `shouldBe` Lit (LDouble 0.1) 35 | 36 | describe "mul" $ do 37 | it "should mul two integers" $ 38 | mul (Lit (LInt 1)) (Lit (LInt 1)) `shouldBe` Lit (LInt 1) 39 | it "should mul two doubles" $ 40 | mul (Lit (LDouble 1.1)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 1.21) 41 | it "should mul an int and a double" $ 42 | mul (Lit (LInt 1)) (Lit (LDouble 1.1)) `shouldBe` Lit (LDouble 1.1) 43 | it "should mul a double and an int" $ 44 | mul (Lit (LDouble 1.1)) (Lit (LInt 1)) `shouldBe` Lit (LDouble 1.1) 45 | 46 | describe "truncate'" $ do 47 | it "should remove trailing zeros" $ 48 | truncate' 1.00000002 `shouldBe` 1.0 49 | it "should round repeating decimal" $ 50 | truncate' 0.8999999 `shouldBe` 0.9 51 | it "should round repeating decimal with leading number" $ 52 | truncate' 1.2999999 `shouldBe` 1.3 53 | it "should round not 1.299993" $ 54 | truncate' 1.299993 `shouldBe` 1.299993 55 | -------------------------------------------------------------------------------- /test/TestMain.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ListPrimitivesSpec 4 | import MathsPrimitives 5 | import EvalSpec 6 | import CallGraphSpec 7 | 8 | main :: IO () 9 | main = do 10 | listprims 11 | mathsprims 12 | evalspec 13 | callGraph 14 | -------------------------------------------------------------------------------- /test/compiler/addition.mml: -------------------------------------------------------------------------------- 1 | let inc x = x + 1; 2 | let main = inc 5 3 | -------------------------------------------------------------------------------- /test/compiler/badType.mml: -------------------------------------------------------------------------------- 1 | let inc x = x + 'a' 2 | let main = inc 4 3 | -------------------------------------------------------------------------------- /test/compiler/badTypeSimple.mml: -------------------------------------------------------------------------------- 1 | -- should fail to compile 2 | let main = 'a' + 2 3 | -------------------------------------------------------------------------------- /test/compiler/duplicateFail.mml: -------------------------------------------------------------------------------- 1 | -- should fail to compile 2 | let x = 1 3 | let two = 2 4 | let p = 3 5 | let two = "two" 6 | let t = 5 7 | 8 | let main = "" 9 | -------------------------------------------------------------------------------- /test/compiler/empty.mml: -------------------------------------------------------------------------------- 1 | -- should throw an error 2 | -------------------------------------------------------------------------------- /test/compiler/funcCall.mml: -------------------------------------------------------------------------------- 1 | let text = "hello microML" 2 | 3 | let main = text >> print 4 | -------------------------------------------------------------------------------- /test/compiler/helloWorld.mml: -------------------------------------------------------------------------------- 1 | -- hello world in microML 2 | let main = scroll "hello microML!!" 3 | -------------------------------------------------------------------------------- /test/compiler/ifStatement.mml: -------------------------------------------------------------------------------- 1 | -- test of a simple if statement 2 | 3 | let main = 4 | let x = 2 in 5 | if x == 2 then scroll "hello" else scroll "goodbye" 6 | -------------------------------------------------------------------------------- /test/compiler/letDecl.mml: -------------------------------------------------------------------------------- 1 | -- | a test of a let .. in construction 2 | 3 | let main = 4 | let s = "hello microML" 5 | in scroll s 6 | -------------------------------------------------------------------------------- /test/compiler/linkedUnreachable.mml: -------------------------------------------------------------------------------- 1 | -- should fail to compile as two functions (although calling each other) 2 | -- are not reachable from main 3 | 4 | let inc x = x + 1 5 | let incAgain x = inc (inc x) 6 | let double x = x * 2 7 | let compose x y z = x (y z) 8 | 9 | let main = compose double double 5 10 | 11 | -------------------------------------------------------------------------------- /test/compiler/multiFunc.mml: -------------------------------------------------------------------------------- 1 | let text1 = "hello, " 2 | let text2 = "there" 3 | 4 | let main = (text1 ++ text2) >> scroll 5 | -------------------------------------------------------------------------------- /test/compiler/multiLet.mml: -------------------------------------------------------------------------------- 1 | -- a test of multiple nested let expressions 2 | 3 | let main = 4 | let s = "hello" in 5 | let t = "there" in 6 | scroll s ++ t 7 | -------------------------------------------------------------------------------- /test/compiler/receiver.mml: -------------------------------------------------------------------------------- 1 | -- | simple receiver program for robotics testing 2 | 3 | let onData mbe = 4 | let s = "uBit.radio.datagram.recv()" in 5 | if s == "1" 6 | then print "A" 7 | else print "B" 8 | 9 | let main = 10 | let setGroup = 123 in 11 | let enable = true in 12 | listen >> onData >> print 13 | -------------------------------------------------------------------------------- /test/compiler/unreachable.mml: -------------------------------------------------------------------------------- 1 | -- inc is a redundant function definition, not used in the program. It should 2 | -- fail to compile with an appropriate message 3 | 4 | let double x = x * 2 5 | let compose x y = \z -> x (y z) 6 | let inc x = x + 1 7 | 8 | let main = compose double double 2 9 | -------------------------------------------------------------------------------- /utils/compilerTests.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/bash 2 | 3 | ml=$(which microML) 4 | FILES="../test/compiler/*.mml" 5 | 6 | for f in $FILES 7 | do 8 | filename=$(basename "$f") 9 | newfile="${filename%.*}" 10 | if [ -x "$ml" ]; then 11 | printf "attempting to compile \e[1m%s\e[0m\n" "$filename" 12 | microML -c "$f" "../test/compiler/res/$newfile" 13 | else 14 | echo "\e[31mError:\e[0m microML is not in your system path" 15 | break 16 | fi 17 | done 18 | -------------------------------------------------------------------------------- /utils/microML.vim/autoload/funcs.vim: -------------------------------------------------------------------------------- 1 | let g:funcs = split('id 2 | \ map 3 | \ foldr 4 | \ foldl 5 | \ foldr1 6 | \ foldl1 7 | \ const 8 | \ let 9 | \ else 10 | \ then 11 | \ filter 12 | \ reverse 13 | \ head 14 | \ tail 15 | \ zero? 16 | \ odd? 17 | \ even? 18 | \ positive? 19 | \ negative? 20 | \ show 21 | \ read 22 | \ succ 23 | \ flip 24 | \ twice 25 | \ pipe 26 | \ compose 27 | \ length 28 | \ drop 29 | \ take 30 | \ init 31 | \ quicksort 32 | \ mergesort') 33 | -------------------------------------------------------------------------------- /utils/microML.vim/autoload/microMLcomplete.vim: -------------------------------------------------------------------------------- 1 | runtime autoload/funcs.vim 2 | 3 | function! microMLcomplete#CompleteMicroML(findstart, base) abort 4 | if a:findstart 5 | " locate the start of the word 6 | let l:line = getline('.') 7 | let l:start = col('.') - 1 8 | while l:start > 0 && l:line[l:start - 1] =~ '\a' 9 | let l:start -= 1 10 | endwhile 11 | return l:start 12 | else 13 | let l:res = [] 14 | for l:m in g:funcs 15 | if l:m =~ '^' . a:base 16 | call add(l:res, l:m) 17 | endif 18 | endfor 19 | return l:res 20 | endif 21 | endfun 22 | -------------------------------------------------------------------------------- /utils/microML.vim/ftdetect/microML.vim: -------------------------------------------------------------------------------- 1 | " microML 2 | autocmd BufNewFile,BufRead *.mml set filetype=microML 3 | -------------------------------------------------------------------------------- /utils/microML.vim/ftplugin/microML.vim: -------------------------------------------------------------------------------- 1 | " shamelessly ripped off from Twinside/vim-haskellFold on github 2 | 3 | function! GetMMLFold(lnum) 4 | let l:line = getline( a:lnum ) 5 | 6 | " Beginning of comment 7 | if l:line =~? '\v^\s*--' || l:line =~? '\v^\s*(\*' 8 | return '2' 9 | endif 10 | 11 | if l:line =~? '\v^\s*$' 12 | let l:nextline = getline(a:lnum + 1) 13 | if l:nextline =~# '^--' || l:nextline =~? '^(\*' 14 | return '0' 15 | else 16 | return '-1' 17 | endif 18 | endif 19 | return '1' 20 | endfunction 21 | 22 | fun! MMLFoldText() 23 | let l:i = v:foldstart 24 | let l:retVal = '' 25 | let l:began = 0 26 | 27 | let l:commentOneLine = '^\s*--.*$' 28 | let l:monoLineComment = '^\s*--.*$' 29 | let l:emptyLine = '^\s*$' 30 | let l:nonEmptyLine = '^\s\+\S' 31 | let l:multiLineCommentBegin = '^\s*(\*' 32 | let l:multiLineCommentEnd = '^\s*\*)' 33 | 34 | let l:isMultiLine = 0 35 | 36 | let l:line = getline(l:i) 37 | 38 | while l:i <= v:foldend 39 | if l:isMultiLine 40 | if l:line =~ l:multiLineCommentEnd 41 | let l:isMultiLine = 0 42 | let l:line = substitute(l:line, '.*\*)', '', '') 43 | 44 | if l:line =~ l:emptyLine 45 | let l:i = l:i + 1 46 | let l:line = getline(l:i) 47 | end 48 | else 49 | let l:i = l:i + 1 50 | let l:line = getline(l:i) 51 | end 52 | else 53 | if l:line =~ l:multiLineCommentBegin 54 | let l:isMultiLine = 1 55 | continue 56 | elseif l:began == 0 && !(l:line =~ l:commentOneLine) 57 | let l:retVal = substitute(l:line, l:monoLineComment, ' ', '') 58 | let l:began = 1 59 | elseif l:began != 0 && l:line =~ l:nonEmptyLine 60 | let l:tempVal = substitute(l:line, '\s\+\(.*\)$', ' \1', '') 61 | let l:retVal = l:retVal . substitute(l:tempVal, '\s\+--.*', ' ', '') 62 | elseif l:began != 0 63 | break 64 | endif 65 | 66 | let l:i = l:i + 1 67 | let l:line = getline(l:i) 68 | endif 69 | endwhile 70 | 71 | if l:retVal ==# '' 72 | return foldtext() 73 | endif 74 | 75 | return l:retVal 76 | endfunction 77 | 78 | 79 | setlocal foldexpr=GetMMLFold(v:lnum) 80 | setlocal foldtext=MMLFoldText() 81 | setlocal foldmethod=expr 82 | -------------------------------------------------------------------------------- /utils/microML.vim/syntax/microML.vim: -------------------------------------------------------------------------------- 1 | " 2 | " this syntax file is based on that for SML 3 | " maintained by Markus Mottl 4 | " Fabrizio Zeno Cornelli 5 | " 6 | " 7 | " Vim syntax file 8 | " Language: microML 9 | " Filenames: *.mml 10 | " Maintainers: David Kelly 11 | " URL: http://www.github.com/kellino/microML 12 | " Last Change: 07 August 2016 13 | 14 | " For version 5.x: Clear all syntax items 15 | " For version 6.x: Quit when a syntax file was already loaded 16 | if v:version < 600 17 | syntax clear 18 | elseif exists('b:current_syntax') 19 | finish 20 | endif 21 | 22 | " microML is case sensitive. 23 | syn case match 24 | 25 | " lowercase identifier - the standard way to match 26 | syn match mmlLCIdentifier /\<\(\l\|_\)\(\w\|'\)*\>/ 27 | 28 | syn match mmlKeyChar "|" 29 | 30 | " Errors 31 | syn match mmlBrackErr "\]" 32 | syn match mmlParenErr ")" 33 | syn match mmlCommentErr "\*)" 34 | syn match mmlThenErr "\" 35 | 36 | " Some convenient clusters 37 | syn cluster mmlAllErrs contains=mmlBrackErr,mmlParenErr,mmlCommentErr,mmlThenErr 38 | 39 | syn cluster mmlAENoParen contains=mmlBraceErr,mmlBrackErr,mmlCommentErr,mmlEndErr,mmlThenErr 40 | 41 | syn cluster mmlContained contains=mmlTodo,mmlPreDef,mmlModParam,mmlModParam1,mmlPreMPRestr,mmlMPRestr,mmlMPRestr1,mmlMPRestr2,mmlMPRestr3,mmlModRHS,mmlFuncWith,mmlFuncStruct,mmlModTypeRestr,mmlModTRWith,mmlWith,mmlWithRest,mmlModType,mmlFullMod,mmlRecordField 42 | 43 | 44 | " Enclosing delimiters 45 | syn region mmlEncl transparent matchgroup=mmlKeyword start="(" matchgroup=mmlKeyword end=")" contains=ALLBUT,@mmlContained,mmlParenErr 46 | syn region mmlEncl transparent matchgroup=mmlKeyword start="\[" matchgroup=mmlKeyword end="\]" contains=ALLBUT,@mmlContained,mmlBrackErr 47 | syn region mmlEncl transparent matchgroup=mmlKeyword start="#\[" matchgroup=mmlKeyword end="\]" contains=ALLBUT,@mmlContained,mmlBrackErr 48 | 49 | " Comments 50 | syn region mmlComment start="(\*" end="\*)" contains=mmlComment,mmlTodo 51 | syn region mmlLineComment start="--" end="\n" contains=mmlString, mmlTodo 52 | syn keyword mmlTodo contained TODO FIXME XXX 53 | 54 | " let 55 | "syn region mmlEnd matchgroup=mmlKeyword start="\" contains=ALLBUT,@mmlContained,mmlEndErr 56 | syn match mmlLet "\" 57 | 58 | " if 59 | syn region mmlNone matchgroup=mmlKeyword start="\" matchgroup=mmlKeyword end="\" contains=ALLBUT,@mmlContained,mmlThenErr 60 | 61 | syn keyword mmlKeyword if then else and or not xor 62 | syn keyword mmlKeyword let in case of 63 | 64 | syn keyword mmlType Boolean Number Char String 65 | 66 | syn keyword mmlOperator and or not xor 67 | 68 | syn keyword mmlBoolean true false 69 | syn match mmlConstructor "(\s*)" 70 | syn match mmlConstructor "\[\s*\]" 71 | syn match mmlConstructor "#\[\s*\]" 72 | syn match mmlConstructor "\u\(\w\|'\)*\>" 73 | 74 | syn match mmlCharacter +#"\\""\|#"."\|#"\\\d\d\d"+ 75 | syn match mmlCharErr +#"\\\d\d"\|#"\\\d"+ 76 | syn region mmlString start=+"+ skip=+\\\\\|\\"+ end=+"+ 77 | 78 | syn match mmlKeyChar "=" 79 | syn match mmlKeyChar "<" 80 | syn match mmlKeyChar ">" 81 | syn match mmlKeyChar "%" 82 | syn match mmlKeyChar ";" 83 | syn match mmlKeyChar "\*" 84 | syn match mmlFunDef "->" 85 | syn match mmlOperator "\^" 86 | syn match mmlOperator "/" 87 | syn match mmlOperator ":" 88 | syn match mmlAnyVar "\<_\>" 89 | 90 | syn match mmlNumber "\<-\=\d\+\>" 91 | syn match mmlNumber "\<-\=0[x|X]\x\+\>" 92 | 93 | " Define the default highlighting. 94 | " For version 5.7 and earlier: only when not done already 95 | " For version 5.8 and later: only when an item doesn't have highlighting yet 96 | if v:version >= 508 || !exists('did_mml_syntax_inits') 97 | if v:version < 508 98 | let g:did_mml_syntax_inits = 1 99 | command -nargs=+ HiLink hi link 100 | else 101 | command -nargs=+ HiLink hi def link 102 | endif 103 | 104 | HiLink mmlBraceErr Error 105 | HiLink mmlBrackErr Error 106 | HiLink mmlParenErr Error 107 | 108 | HiLink mmlKeyword Type 109 | HiLink mmlLet Type 110 | 111 | HiLink mmlCommentErr Error 112 | 113 | HiLink mmlEndErr Error 114 | HiLink mmlThenErr Error 115 | 116 | HiLink mmlCharErr Error 117 | 118 | HiLink mmlComment Comment 119 | HiLink mmlLineComment Comment 120 | 121 | HiLink mmlKeyChar Keyword 122 | HiLink mmlAnyVar Keyword 123 | HiLink mmlTopStop Keyword 124 | HiLink mmlOperator Keyword 125 | 126 | HiLink mmlBoolean Boolean 127 | HiLink mmlCharacter Character 128 | HiLink mmlNumber Number 129 | HiLink mmlReal Float 130 | HiLink mmlString String 131 | HiLink mmlType Type 132 | HiLink mmlTodo Todo 133 | HiLink mmlEncl Keyword 134 | 135 | delcommand HiLink 136 | endif 137 | 138 | let b:current_syntax = 'mml' 139 | 140 | " vim: ts=8 141 | -------------------------------------------------------------------------------- /utils/microMLrc: -------------------------------------------------------------------------------- 1 | ## config file for microML 2 | 3 | ## simple ansi colour codes, see https://en.wikipedia.org/wiki/ANSI_escape_code for more details 4 | # first of all, find out what type of terminal you have 5 | 6 | # $ echo $TERM 7 | # if the response says 256, then you can choose numbers between 0 and 255 for your colours 8 | # otherwise you can choose from 31 to 39 9 | 10 | [colourscheme] 11 | bold = 1 12 | number = 160 13 | string = 54 14 | char = 34 15 | boolean = 226 16 | error = 31 17 | arrow = 34 18 | prompt = 33 19 | --------------------------------------------------------------------------------