├── Caramel.cabal ├── IO ├── Example │ └── fib.js ├── README.md └── lambda.js ├── LICENSE ├── README.markdown ├── Setup.hs └── src ├── Caramel.hs ├── Lambda.hs ├── Main.hs ├── Transmogrifier.hs └── Util.hs /Caramel.cabal: -------------------------------------------------------------------------------- 1 | name: Caramel 2 | version: 0.1.0.0 3 | synopsis: A modern syntax for the oldest programming language in the world. 4 | license: MIT 5 | license-file: LICENSE 6 | author: Victor Hernandes Silva Maia 7 | maintainer: srvictormaia@gmail.com 8 | homepage: https://github.com/srvictormaia/caramel 9 | category: Language 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable mel 14 | main-is: Main.hs 15 | build-depends: base >=4.6 && <4.9, containers >= 0.5 && < 0.6, directory >= 1.2 && < 1.3, split >=0.2 && <0.3 16 | default-language: Haskell2010 17 | hs-source-dirs: src 18 | 19 | library 20 | exposed-modules: Caramel 21 | other-extensions: OverloadedStrings, FlexibleContexts 22 | build-depends: base >=4.6 && <4.9, containers >=0.5 && <0.6, split >=0.2 && <0.3 23 | default-language: Haskell2010 24 | hs-source-dirs: src 25 | -------------------------------------------------------------------------------- /IO/Example/fib.js: -------------------------------------------------------------------------------- 1 | // JS<->Lambda datatype conversors. 2 | var lambda = require("../lambda.js"); 3 | 4 | // The function was obtained from the Lambda Calculus using `mel fib.js`. 5 | // `lambda.natFn` makes it operate on JS's Number (such as `3`), not lambda 6 | // numbers (such as `(function(f){return function(x){return f(f(f(x)))}})`). 7 | var fib = lambda.natFn(function(a){return a((function(b){return b((function(c){return (function(d){return (function(e){return e(d)((function(f){return (function(g){return c(f)(d(f)(g))})}))})})}))}))((function(b){return b((function(c){return (function(d){return d})}))((function(c){return (function(d){return c(d)})}))}))((function(b){return (function(c){return b})}))}) 8 | 9 | // fib(10) == 55 10 | console.log(fib(10)) 11 | -------------------------------------------------------------------------------- /IO/README.md: -------------------------------------------------------------------------------- 1 | # Caramel's transmogrifer IO utils. 2 | 3 | Lambda Calculus is a language of pure computation and doesn't have any notion of IO. That way, if you need to interface with the real world, you need to inject a Lambda Calculus program into a "real world" programming language, such as JavaScript. A problem with that is popular languages use native datatypes (such as Int), which won't be compatible with Lambda Calculus datatypes (such as Church-encoded numbers). Caramel's IO libraries convert native datatypes to lambda-based datatypes, enabling you to use Caramel programs in any environment. 4 | 5 | Example: using Fib on JavaScript. 6 | 7 | var lambda = require("../lambda.js"); 8 | 9 | // The function was obtained from the Lambda Calculus using `mel fib.js`. 10 | // `lambda.natFn` makes it operate on JS's Number (such as `3`), not lambda 11 | // numbers (such as `(function(f){return function(x){return f(f(f(x)))}})`). 12 | var fib = lambda.natFn(function(a){return a((function(b){return b((function(c){return (function(d){return (function(e){return e(d)((function(f){return (function(g){return c(f)(d(f)(g))})}))})})}))}))((function(b){return b((function(c){return (function(d){return d})}))((function(c){return (function(d){return c(d)})}))}))((function(b){return (function(c){return b})}))}) 13 | 14 | // fib(10) == 55 15 | console.log(fib(10)) 16 | 17 | Another problem is that most programs obtained this way will be terribly inefficient due to: 18 | 19 | 1. Unary numbers being used - you should prefer binary formats (TODO: implement Int/Float algebra on Prelude). 20 | 21 | 2. Most programming languages not implementing functions optimally. See the [http://github.com/MaiaVictor/optlam](Optlam) repository for more info. 22 | 23 | From some tests, I believe using binary numbers and good functional evaluators (such as GHC, some Scheme compilers) can be performant enough to run a few simple lambda calculus applications and games even in slow computers. (TODO: POC) 24 | 25 | # TODO 26 | 27 | The IO utils are only implemented for JavaScript at this point. Implementing IO utils for other languages should be an easy task. 28 | 29 | -------------------------------------------------------------------------------- /IO/lambda.js: -------------------------------------------------------------------------------- 1 | // lambda.js 2 | // 3 | // This lib converts JavaScript native datatypes to/from Lambda-encoded datatypes, 4 | // so you can use Lambda-Calculus functions inside a JavaScript environment. 5 | // 6 | // Convention: 7 | // 8 | // Normally named functions receive JS datatypes and return Lambda datatypes. 9 | // Functions ending in "_" receive Lambda datatypes and return JS datatypes. 10 | // 11 | // Example: 12 | // 13 | // // Converts JS's number 3 to Church number. 14 | // console.log(nat(3)); // output: [Function] 15 | // 16 | // // Converts the Church number three to JS's number 3. 17 | // // Notice that `nat(nat_(x)) == x`. 18 | // console.log(nat_(nat(3))); // output: 3 19 | // 20 | // // Calculates 3^3 using Church numbers (exponentiation = application). 21 | // console.log(nat_((nat(3))(nat(3)))); // output: 27 22 | // 23 | 24 | var lambda = (function(){ 25 | // Converts a JavaScript native Number to a Church-encoded number. 26 | // nat :: JSNumber -> ChurchNat 27 | var nat = function(n){ 28 | return(function(f){ 29 | return(function(a){ 30 | for(var i=0;i JSNumber 39 | var nat_ = function(n){ 40 | return((n(function(a){ 41 | return(a+1) 42 | }))(0)) 43 | }; 44 | 45 | // Converts a function on Church-encoded numbers to a function that 46 | // works on native JavaScript numbers. 47 | // natFn :: (Nat -> Nat) -> (JSNumber -> JSNumber) 48 | var natFn = function(f){ 49 | return function(x){ 50 | return nat_(f(nat(x))); 51 | }; 52 | }; 53 | 54 | return { 55 | nat : nat, 56 | nat_ : nat_, 57 | natFn : natFn}; 58 | })(); 59 | if (typeof module.exports !== "undefined") module.exports = lambda; 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Victor Hernandes Silva Maia 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Caramel 2 | 3 | 🍮 A modern syntax for the oldest programming language in the world. 🍮 4 | 5 | Caramel is a set of bidirectional, Haskell-inspired **syntax-sugars** that are expanded to, and contracted from, [λ-Calculus](https://en.wikipedia.org/wiki/Lambda_calculus) terms. Caramel is not a new programming language - it is a new syntax for an old language, enabling it to be written in a much saner way. The implementation aims to be simple and terse and currently stands at around 350 lines of commented Haskell code. 6 | 7 | ## Example 8 | 9 | The following Caramel (`.mel`) file implements QuickSort on the Lambda Calculus: 10 | 11 | ```haskell 12 | -- example_qsort.mel 13 | 14 | qsort = (match cons nil) 15 | nil = [] 16 | cons x xs = (flatten [smalls,[x],bigs]) 17 | smalls = (qsort (filter (< x) xs)) 18 | bigs = (qsort (filter (> x) xs)) 19 | 20 | qsort_example = (fix qsort [5,6,1,4,3,7,2]) 21 | ``` 22 | 23 | You can run it by typing `mel qsort_example` on the Prelude directory. It looks for the `qsort_example` definition through all `.mel` files on the dir, expands it to a pure Lambda Calculus term, evaluates (to [beta normal form](https://en.wikipedia.org/wiki/Beta_normal_form)), and then prints the result on the Caramel syntax: 24 | 25 | ```haskell 26 | $ cd Prelude 27 | $ mel qsort_example 28 | [1,2,3,4,5,6,7] 29 | ``` 30 | 31 | If you want to see the actual Lambda Calculus code, just append `.lam` to the name of the term you want to evaluate - it will output the unsugared view of the term, using [De Bruijn Index](https://en.wikipedia.org/wiki/De_Bruijn_index): 32 | 33 | ```bash 34 | $ mel qsort_example.lam 35 | λλ((1 λλ(1 0)) 36 | ((1 λλ(1 (1 0))) 37 | ((1 λλ(1 (1 (1 0)))) 38 | ((1 λλ(1 (1 (1 (1 0))))) 39 | ((1 λλ(1 (1 (1 (1 (1 0)))))) 40 | ((1 λλ(1 (1 (1 (1 (1 (1 0))))))) 41 | ((1 λλ(1 (1 (1 (1 (1 (1 (1 0)))))))) 42 | 0 ))))))) 43 | # (This is how [1,2,3,4,5,6,7] is usually represented on the Lambda Calculus.) 44 | # (Identation added manually.) 45 | ``` 46 | 47 | More examples can be found on the Prelude directory, with the "example" prefix. I suggest looking at [this one](https://github.com/MaiaVictor/caramel/blob/master/Prelude/example_many_things.mel) first. 48 | See [`example_qsort.mel`](https://github.com/MaiaVictor/caramel/blob/master/Prelude/example_qsort.mel) for more on the QuickSort example. Mind most of the remaining of files there were written before Caramel and need some refactoring to better show Caramel's syntax. 49 | 50 | # Transmogrifiers 51 | 52 | Transmogrifiers convert Lambda Calculus programs to popular programming languages, allowing Caramel code to be used in almost any environment. To invoke a transmogrifier, use `mel your_term.`, where `` is the extension of the target language's files. This example translates the λ-calculus number `4` to different languages: 53 | 54 | ```bash 55 | # JavaScript 56 | $ mel 4.js 57 | (function(a){return (function(b){return a(a(a(a(b))))})}) 58 | 59 | # Python 60 | $ mel 4.py 61 | (lambda a: (lambda b: a(a(a(a(b)))))) 62 | 63 | # Ruby 64 | $ mel 4.rb 65 | (->(a){(->(b){a.(a.(a.(a.(b))))})}) 66 | 67 | # Lua 68 | $ mel 4.lua 69 | (function (a) return (function (b) return a(a(a(a(b)))) end) end) 70 | 71 | # Scheme 72 | $ mel 4.scm 73 | (lambda(a)(lambda(b)(a (a (a (a b)))))) 74 | 75 | # Haskell 76 | $ mel 4.hs 77 | (let (#) = unsafeCoerce in (\a->(\b->(a#(a#(a#(a#b))))))) 78 | 79 | # John Tromp's Binary Lambda Calculus 80 | $ mel 4.blc 81 | 000001100110011001100 82 | ``` 83 | 84 | Here is how you can call the `fib` definition on Prelude from JavaScript: 85 | 86 | ```javascript 87 | // Utils to convert between native Numbers and Lambda-encoded numbers. 88 | var lambda = require("IO/lambda.js"); 89 | 90 | // Obtained using `mel fib.js` 91 | var fib = lambda.natFn(function(a){return a((function(b){return b((function(c){return (function(d){return (function(e){return e(d)((function(f){return (function(g){return c(f)(d(f)(g))})}))})})}))}))((function(b){return b((function(c){return (function(d){return d})}))((function(c){return (function(d){return c(d)})}))}))((function(b){return (function(c){return b})}))}) 92 | 93 | // Outputs 55 94 | console.log(fib(10)) 95 | ``` 96 | 97 | See `IO` directory for more information in how to use Caramel functions inside different environments. 98 | 99 | # Featured syntax-sugars 100 | 101 | * [Lambdas](#lambdas) 102 | * [Application](#application) 103 | * [Let and variable assignment](#let-and-variable-assignment) 104 | * [Where and layout syntax](#where-and-layout-syntax) 105 | * [Top-level definitions](#top-level-definitions) 106 | * [Natural Numbers](#natural-numbers) 107 | * [Lists](#lists) 108 | * [Tuples](#tuples) 109 | * [Chars](#chars) 110 | * [Strings](#strings) 111 | * [Words](#words) 112 | * [Comments](#comments) 113 | * [ADTs](#adts) 114 | 115 | ## Lambdas 116 | 117 | Lambda Calculus's lambdas are anonymous, single argument functions. Caramel's lambda syntax allows creating anonymous functions with multiple named variables separated from the body by an arrow. 118 | 119 | Example: 120 | 121 | ```haskell 122 | (a b c -> (a (b c))) 123 | ``` 124 | 125 | Expands to/from the λ-calculus as: 126 | 127 | ```haskell 128 | λλλ(2 (1 0)) 129 | ``` 130 | 131 | (Remember numbers on the λ-calculus expressions are bruijn-indexed variables, not natural numbers.) 132 | 133 | ## Application 134 | 135 | Lambda Calculus applications substitutes bound variables of a lambda abstraction by the applied term. Caramel's application syntax uses parenthesis and allows you to omit redundant ones. Using f, x and y as placeholders: 136 | 137 | ```haskell 138 | (f x y z) 139 | ``` 140 | 141 | Expands to/from: 142 | 143 | ```haskell 144 | (((f x) y) z) 145 | ``` 146 | 147 | ## Let and variable assignment 148 | 149 | Let expressions are syntax for the assignment of variables. As opposed to Haskell, the `let` keyword isn't used, but `;`-separated assignments enclosed by curly brackets, followed by the expression on which those definitions are visible. They also allow named function definitions exactly like Haskell. They are recursive, so you don't have to care about the order you write them. Self-referential terms aren't made recursive - they instead gain an extra bound variable in order to be used with fixed-point combinators. Let expressions are expanded to lambda applications. 150 | 151 | ```haskell 152 | {double = (mul 2); 153 | square x = (mul x x); 154 | (double (square 3))} 155 | ``` 156 | 157 | Is the same as: 158 | 159 | ```haskell 160 | ((double -> ((square -> (double (square 3))) (x -> (mul x x)))) (mul 2)) 161 | ``` 162 | 163 | ## Where and Layout syntax 164 | 165 | Properly idented newlines after a term are interpreted as local definitions and nicely expanded to "let" expressions. This enables a layout syntax very similar to Haskell's `where` clauses, although without the `where` keyword. 166 | 167 | ```haskell 168 | (double (square 3)) 169 | double = (mul 2) 170 | square x = (mul x x) 171 | ``` 172 | 173 | This is the same as the `let` expression above. See [this example](...) for more info. 174 | 175 | ## Top-level definitions 176 | 177 | Top-level definitions are just expanded to the implicit `where` (and, thus, `let`) syntax. Example: 178 | 179 | ```haskell 180 | -- some top level variables 181 | a = 3 182 | b = 2 183 | 184 | -- an example program 185 | example_tld = (mul a b) 186 | ``` 187 | 188 | By calling `mel example_tld`, the above program is expanded as follows: 189 | 190 | ```haskell 191 | example_tld 192 | a = 3 193 | b = 2 194 | example_tld = (mul a b) 195 | ... 196 | {a = 3; b = 2; example_tld = (mul a b); example_tld} 197 | ... 198 | ((a -> ((b -> ((example_tld -> example_tld) (mul a b))) 2)) 3) 199 | ... 200 | (λ(λ(λ(λ0 ((2 λλ(1 (1 (1 0)))) λλ(1 (1 0)))) λλ(1 (1 0))) λλ(1 (1 (1 0)))) λλλ(2 (1 0))) 201 | ... 202 | λλ(1 (1 (1 (1 (1 (1 0)))))) 203 | ``` 204 | 205 | Which is printed as `6`, the result of `3 * 2`. 206 | 207 | ## Natural Numbers 208 | 209 | The simplest implementation of natural numbers on the Lambda Calculus is the church encoding. Caramell's Nat syntax is just the number literal in ASCII, which is expanded to church-encoded numbers, allowing you to input them on the lambda calculus without dealing with the encoding yourself. It is just an input method - church numbers can be converted to any format at compile time, in case you don't want them. 210 | 211 | ```haskell 212 | 3 213 | ``` 214 | 215 | Expands to/from the Lambda Calculus as: 216 | 217 | ```haskell 218 | λλ(1 (1 (1 0))) 219 | ``` 220 | 221 | ## Lists 222 | 223 | The simplest implementation of lists on the Lambda Calculus is, too, the church encoding. Similarly to natural numbers, Camamell's Lst syntax is the same as Haskell and allows you to input lists on the Lambda Calculus without having to deal with the church encoding. After inputing, those can always be converted to any format you like, such as the Scott Encoding. Using, a, b and c as placeholders: 224 | 225 | ```haskell 226 | [a, b, c] 227 | ``` 228 | 229 | Is the same as: 230 | 231 | ```haskell 232 | (cons nil -> (cons a (cons b (cons c nil)))) 233 | ``` 234 | 235 | And expands to/from the Lambda Calculus as: 236 | 237 | ```haskell 238 | λλ(1 a (1 b (1 c 0))) 239 | ``` 240 | 241 | ## Tuples 242 | 243 | Very similarly to natural numbers and lists, tuples have a natural implementation based on the Church encoding. Caramel's syntax for tuples is very similar to the application syntax, in that it uses parenthesis. The key difference is the presence of commas - with commas, it is a tuple, without them, it is an application. If it has only one element (e.g, `(7)`), is is an 1-tuple, not a redundant paren. 244 | 245 | ```haskell 246 | (a, b, c) 247 | ``` 248 | 249 | Is the same as: 250 | 251 | ```haskell 252 | (t -> (t a b c)) 253 | ``` 254 | 255 | And expands to/from the Lambda Calculus as: 256 | 257 | ```haskell 258 | λ(((0 a) b) c) 259 | ``` 260 | 261 | ## Chars 262 | 263 | Chars can be encoded as 8-tuples of booleans. For example, the char 'a', which is 97 in ASCII and 01100001 in binary, can be represented as tuple (t -> (t F T T F F F F T)). The syntax is the usual: 264 | 265 | ```haskell 266 | 'a' 267 | ``` 268 | 269 | Which is expanded to/from the Lambda Calculus as: 270 | 271 | ```haskell 272 | λ((((((((0 F) T) T) F) F) F) F) T) 273 | ``` 274 | 275 | Where `F = λλ0` (false) and `T = λλ1` (true). 276 | 277 | ## Strings 278 | 279 | Strings are just lists of chars. 280 | 281 | ```haskell 282 | "abcd" 283 | ``` 284 | 285 | The program above is expanded as: 286 | 287 | ```haskell 288 | ['a', 'b', 'c', 'd'] 289 | ... 290 | (cons nil -> (cons 'a' (cons 'b' (cons 'c' (cons 'd' nil))))) 291 | ... 292 | λλ ((T λ((((((((0 F) T) T) F) F) F) F) T)) 293 | ((T λ((((((((0 F) T) T) F) F) F) T) F)) 294 | ((T λ((((((((0 F) T) T) F) F) F) T) T)) 295 | ((T λ((((((((0 F) T) T) F) F) T) F) F)) 296 | 0 )))) 297 | ``` 298 | 299 | Where `F = λλ0` (false) and `T = λλ1` (true). 300 | 301 | ## Words 302 | 303 | Words are 32-bit unsigned inters. The encoding is the same as chars, except the function of 2 arguments returns a 32-tuple instead of an 8-tuple. The syntax is a hash symbol (`#`) followed by a number literal. It is a minor shortcut since one could already write a lambda calculus function called `#` which would convert a church number to a word, and just write (# 123) instead of #123. 123 in binary is 00000000 00000000 00000000 01111011, so... 304 | 305 | ```haskell 306 | #123 307 | ``` 308 | 309 | Expands to/from the Lambda Calculus as: 310 | 311 | ```haskell 312 | λ((((((((((((((((((((((((((((((((0 313 | F) F) F) F) F) F) F) F) 314 | F) F) F) F) F) F) F) F) 315 | F) F) F) F) F) F) F) F) 316 | F) T) T) T) T) F) T) T) 317 | ``` 318 | 319 | Where `F = λλ0` (false) and `T = λλ1` (true). 320 | 321 | ## Comments 322 | 323 | Anything between double hyphen (`--`) and a newline is ignored by the compiler. 324 | 325 | ```haskell 326 | -- Hello I'm a comment 327 | a = 7 -- I'm too 328 | ``` 329 | 330 | ## ADTs 331 | 332 | First-class Algebraic DataTypes (ADTs) are experimental and the most complex feature here. The point is that defining functions for a datatype on the λ-calculus is hard when you have to deal with church/scott encodings yourself. Combining ADTs with **high-order derivers**, many functions such as (on the List case) `cons`, `nil` (constructors), `head`, `tail` (getters), `map`, `zipWith` (some algorithms), as well as lenses, monads and so on, can be derived automatically. While this already works (for Scott encodings only), it is very likely that my design is imperfect and there are better solutions. Example: 333 | 334 | In Haskell, we have: 335 | 336 | ```haskell 337 | data Bool = True | False deriving Show 338 | data List a = Cons { head :: a, tail :: List a } | Nil deriving Show 339 | data Tree a = Node a (List (Tree a)) deriving Show 340 | type TLB = Tree (List Bool) 341 | ``` 342 | 343 | In Caramel, we have: 344 | 345 | ```haskell 346 | Bool = #{True {} | False {}} 347 | List a = #{Cons {head : a, tail : *} | Nil {}} 348 | Tree a = #{Tree {tag : a, children : (List *)}} 349 | TLB = (Tree (List Bool)) 350 | ``` 351 | 352 | Notice recursion uses the special `*` character, repeated n times, which works like bruijn indexed variables, refering to the nth enclosing complete ADT. Polymorphic types are just functions returning ADTs. Also, the syntax does not (as a design principle) create any top level definition. We can get many free functions for those datatypes using **high-order derivers** such as `Ctor`, `Show`, `Match`, `Getter`, `Fold`. 353 | 354 | ```haskell 355 | Bool = #{True | False} 356 | True = (Ctor 0 Bool) 357 | False = (Ctor 1 Bool) 358 | show = (Show Bool) 359 | if = (Match Bool) 360 | ... and so on 361 | ``` 362 | Note this has nothing to do with types or typechecking. 363 | 364 | Consult [`Prelude/derivers.mel`](https://github.com/maiavictor/caramel/blob/master/Prelude/derivers.mel) for the available derivers. 365 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Caramel.hs: -------------------------------------------------------------------------------- 1 | module Caramel where 2 | 3 | import Control.Applicative ((<*>),(<$>)) 4 | import Control.Monad (msum,replicateM) 5 | import Data.Char 6 | import Data.List (intercalate,foldl1',unfoldr,dropWhileEnd) 7 | import Data.List.Split (splitOn) 8 | import Data.Maybe (listToMaybe,fromJust,isJust) 9 | import Text.ParserCombinators.ReadP 10 | import Text.Printf 11 | import Util 12 | import qualified Data.Map as M 13 | import qualified Data.Set as S 14 | import qualified Lambda as L 15 | import qualified Transmogrifier as T 16 | 17 | import Debug.Trace 18 | 19 | -- The main datatype of Caramel's syntax sugars. 20 | data Caramel 21 | = Lam [String] Caramel 22 | | App [Caramel] 23 | | Var String 24 | | Nat Int 25 | | Lst [Caramel] 26 | | Tup [Caramel] 27 | | Chr Char 28 | | Str String 29 | | Wrd Int 30 | | Adt [(String, [(String, Caramel)])] 31 | | Let [(String,[String],Caramel)] Caramel 32 | deriving Show 33 | 34 | -- The usual fold over Caramel's constructors. 35 | fold 36 | :: ([String]->b->b) 37 | -> ([b]->b) 38 | -> (String->b) 39 | -> (Int->b) 40 | -> ([b]->b) 41 | -> ([b]->b) 42 | -> (Char->b) 43 | -> (String->b) 44 | -> (Int->b) 45 | -> ([(String,[(String,b)])]->b) 46 | -> ([(String,[String],b)]->b->b) 47 | -> Caramel 48 | -> b 49 | fold lam app var num lst tup chr str wrd adt leT = go where 50 | go (Lam vars body) = lam vars (go body) 51 | go (App terms) = app (map go terms) 52 | go (Var name) = var name 53 | go (Nat n) = num n 54 | go (Lst l) = lst (map go l) 55 | go (Tup t) = tup (map go t) 56 | go (Chr c) = chr c 57 | go (Wrd c) = wrd c 58 | go (Str s) = str s 59 | go (Adt ctors) = adt (map (\ (name,ctor) -> (name, map (\ (name,field) -> (name, go field)) ctor)) ctors) 60 | go (Let defs term) = leT (map (\ (name,vars,term) -> (name, vars, go term)) defs) (go term) 61 | 62 | -- Prints a Caramel term with the Caramel syntax. The reverse of parsing. 63 | pretty :: Caramel -> String 64 | pretty term = fold lam app var num lst tup chr str wrd adt leT term [] where 65 | lam vars body = ("(" ++) . (unwords vars ++) . (" -> " ++) . body . (")" ++) 66 | app terms = ("(" ++) . unwords' terms . (")" ++) 67 | var name = (name ++) 68 | num n = (show n ++) 69 | lst l = ("[" ++) . inters' "," l . ("]" ++) 70 | tup l = ("(" ++) . inters' "," l . (")" ++) 71 | chr c = ("'" ++) . ([c] ++) . ("'" ++) 72 | str s = ("\"" ++) . (s ++) . ("\"" ++) 73 | wrd w = (("#" ++ show w) ++) 74 | adt d = undefined 75 | leT d t = ("{"++). (inters' "; " (map (\ (name,vars,term)->(unwords (name:vars)++).(" = "++).term) d)) . ("; "++) . t . ("}"++) 76 | unwords' list = foldr (\ h t s -> (s ++) . h . t " ") (const ([] ++)) list "" 77 | inters' sep list = foldr (\ h t s -> (s ++) . h . t sep) (const ([] ++)) list "" 78 | 79 | -- Parses a Caramel source code into a Caramel term. The reverse of pretty-printing. 80 | -- Does not deal with parse errors properly (TODO). 81 | parse :: String -> Caramel 82 | parse = fst . head . reverse . readP_to_S (term 0) . stripComments where 83 | 84 | -- The pre-processing just removes comments and empty lines 85 | stripComments 86 | = unlines 87 | . (++ [""]) 88 | . filter (not . all isSpace) -- removes empty lines 89 | . map (dropWhileEnd (== ' ')) -- removes endline spaces 90 | . map (head . splitOn "--") -- removes comments 91 | . lines 92 | 93 | -- A term is one of the syntax sugars provided by the DSL, optionally 94 | -- followed by local definitions. 95 | term d = do 96 | parsedTerm <- lam d <++ leT d <++ tup d <++ choice [leT d,app d,str,chr,lst d,adt d] <++ wrd <++ num <++ var 97 | localDefs <- many (string ('\n':replicate ((d+1)*4) ' ') >> def (d+1)) 98 | return $ case localDefs of 99 | [] -> parsedTerm 100 | defs -> Let defs parsedTerm 101 | 102 | -- The sugars below implement Caramel's syntax as defined on the README. 103 | app d = App <$> betweenSpaced (char '(') (char ')') (sepBy (term d) (char ' ')) 104 | 105 | -- A variable. 106 | var = Var <$> choice [word, many1 (char '#')] 107 | 108 | -- A natural number literal. 109 | num = Nat <$> read <$> number 110 | 111 | -- A list. 112 | lst d = Lst <$> sepBetweenSpaced (char '[') (char ',') (char ']') (term d) 113 | 114 | -- A tuple. 115 | tup d = Tup <$> sepBetweenSpaced (char '(') (char ',') (char ')') (term d) 116 | 117 | -- An ASCII character. 118 | chr = Chr <$> do 119 | char '\'' 120 | c <- get 121 | char '\'' 122 | return c 123 | 124 | -- A string (list of ASCII characters). 125 | str = Str <$> (do 126 | char '"' 127 | s <- manyTill get (char '"') 128 | return s) 129 | 130 | -- A word (unsigned integer of 32 bits). 131 | wrd = Wrd <$> read <$> (char '#' >> number) 132 | 133 | -- An algebraic datatype. 134 | adt d = Adt <$> between (string "#(") (char ')') (sepBySpaced ctor (char '|')) where 135 | ctor = (pairedSpaced (,) word (return ()) fields) 136 | fields = sepBySpaces field 137 | field = between (char '(') (char ')') (pairedSpaced (,) word (return ()) (term d)) 138 | 139 | -- An abstraction (lambda). 140 | lam d = between (char '(') (char ')') (pairedSpaced Lam vars (string "->") (term d)) where 141 | vars = sepBy word (char ' ') 142 | 143 | -- An idented definition. 144 | def d = pairedSpaced pair names (char '=') (term d) where 145 | pair = \ (name:vars) value -> (name, vars, value) 146 | names = sepBy word (char ' ' >> space) 147 | 148 | -- A let expression. 149 | leT d = between (char '{' >> skipSpaces) (skipSpaces >> char '}') (pairedSpaced Let defs (char ';') (term d)) where 150 | defs = sepBy (def d) (char ';' >> space) 151 | 152 | -- Some useful parse combinators. This code looks bad and could improve. 153 | number = many1 (satisfy isDigit) 154 | 155 | -- A letter. 156 | letter = satisfy isLetter 157 | 158 | -- A valid word can have alphanumeric and special characters. 159 | word = many1 (satisfy (\ c -> isAlphaNum c || elem c ("_.@:?$!^&|*-+<>~=/"::String))) 160 | 161 | -- Two parses separated by a separator with arbitrary spaces. 162 | pairedSpaced fn left sep right = do 163 | l <- left 164 | space >> sep >> space 165 | r <- right 166 | return (fn l r) 167 | 168 | -- Two parses separated by one or more spaces. 169 | -- pairedBySpaces fn left right = do 170 | -- l <- left 171 | -- space 172 | -- r <- right 173 | -- return (fn l r) 174 | 175 | -- Like sepBy, except with arbitrary spaces between the separator. 176 | sepBySpaced parse separator = 177 | sepBy parse (space >> separator >> space) 178 | 179 | -- Like sepBy, but separated by one or more spaces. 180 | sepBySpaces parse = 181 | sepBy parse (char ' ' >> space) 182 | 183 | -- Like between, expect with arbitrary spaces between the open/close parsers. 184 | betweenSpaced open close parse = 185 | between (open >> space) (space >> close) parse 186 | 187 | -- Combination of sepBySpaced and betweenSpaced. 188 | sepBetweenSpaced open sep close parse = 189 | betweenSpaced open close (sepBy parse (space >> sep >> space)) 190 | 191 | -- Shorthand for skipSpaces. 192 | space = skipSpaces 193 | 194 | -- Converts a Lambda Calculus term to a value of the Caramel DSL. 195 | fromLambda :: L.Term -> Caramel 196 | fromLambda term = L.fold lam app var term (M.empty :: M.Map Int String) 0 where 197 | 198 | -- Converts λ-calculus abstractions to Caramel. 199 | lam body scope depth 200 | = strSugar 201 | . chrSugar 202 | -- . wrdSugar 203 | . lstSugar 204 | . tupSugar 205 | . natSugar 206 | . lamSugar 207 | $ Lam [name] (body (M.insert depth name scope) (depth+1)) 208 | where name = infiniteAlphabet !! depth 209 | 210 | -- Converts λ-calculus applications to Caramel. 211 | app left right scope depth 212 | = appSugar 213 | $ App [left scope depth, right scope depth] 214 | 215 | -- Converts λ-calculus variables to Caramel. 216 | var index scope depth 217 | = Var (scope M.! (depth - index - 1)) 218 | 219 | -- The lam sugar just removes consecutive lambdas, 220 | -- i.e., (a -> (b -> c)) becomes (a b -> c) 221 | lamSugar :: Caramel -> Caramel 222 | lamSugar (Lam names (Lam names' body)) = Lam (names++names') (lamSugar body) 223 | lamSugar term = term 224 | 225 | -- The app sugar just removes redundant parens, 226 | -- i.e., ((f x) y) becomes (f x y) 227 | appSugar :: Caramel -> Caramel 228 | appSugar (App (App args : args')) = appSugar (App (args ++ args')) 229 | appSugar term = term 230 | 231 | -- Church naturals to Nat, 232 | -- i.e., (f x -> (f (f (f x)))) to 3 233 | natSugar :: Caramel -> Caramel 234 | natSugar term = maybe term id (getNat term) where 235 | getNat (Lam [fn,arg] vals) = Nat <$> go vals where 236 | go (App [Var f, p]) | f == fn = (+ 1) <$> go p 237 | go (Var x) | x == arg = Just 0 238 | go _ | otherwise = Nothing 239 | getNat term = Just term 240 | 241 | -- Church lists to Lst, 242 | -- i.e., (c n -> (c 1 (c 2 (c 3 n)))) to [1,2,3] 243 | lstSugar term = maybe term id (getLst term) where 244 | getLst (Lam [cons,nil] cells) = Lst <$> go cells where 245 | go (App [Var c, h, t]) 246 | | c == cons 247 | && not (freeVarInTerm cons h) 248 | && not (freeVarInTerm nil h) 249 | = (h :) <$> go t 250 | go (Var n) | n == nil = Just [] 251 | go _ | otherwise = Nothing 252 | getLst term = Just term 253 | 254 | -- Church tuples to Tup, 255 | -- i.e., (t -> (t 1 2 3)) to (1,2,3) 256 | tupSugar term@(Lam [tupVar] body@(App (Var t : xs))) 257 | | t == tupVar 258 | && not (any (freeVarInTerm tupVar) xs) 259 | = Tup xs 260 | tupSugar term = term 261 | 262 | -- Template function to create the Chr and Wrd sugar. 263 | -- bitVecSugar :: Caramel -> Caramel 264 | bitVecSugar size ctor term = maybe term id (getChr term) where 265 | getBool (Lam [t,f] (Var b)) | b == t = Just False 266 | getBool (Nat 0) = Just True 267 | getBool otherwise = Nothing 268 | getChr (Tup bools) 269 | | length bools == size 270 | && all (isJust . getBool) bools 271 | = Just . ctor . toEnum . toByte . map fromJust . map getBool $ bools 272 | where toByte bools = foldl (\ t h b -> fromEnum h * b + t (b*2)) (const 0) bools 1 273 | getChr term = Just term 274 | 275 | -- Church byte to Chr (ASCII-encoded char), 276 | -- i.e., (f 1 0 -> (f 0 1 1 0 0 0 0 1)) to '\'a\'' 277 | chrSugar :: Caramel -> Caramel 278 | chrSugar = bitVecSugar 8 Chr 279 | 280 | -- Church word to Wrd (Haskell's Word32) 281 | -- i.e., (f 1 0 -> (f 0 0 ...28 zeros... 0 1)) to '1'' 282 | wrdSugar :: Caramel -> Caramel 283 | wrdSugar = bitVecSugar 32 Wrd 284 | 285 | -- Church string (list of Chrs) to Str, 286 | -- i.e., ['a' 'b' 'c' 'd'] to "abcd" 287 | strSugar :: Caramel -> Caramel 288 | strSugar term = maybe term id (getStr term) where 289 | getStr (Lst chrs) | all isChr chrs = Just (Str (map (\ (Chr c) -> c) chrs)) where 290 | isChr (Chr _) = True 291 | isChr otherwise = False 292 | getStr term = Just term 293 | 294 | -- TODO: ADT fromLambda 295 | adt = undefined 296 | 297 | -- Is given variable free in a term? 298 | freeVarInTerm :: String -> Caramel -> Bool 299 | freeVarInTerm varName = elem varName . freeVars 300 | 301 | -- Converts a value of the Caramel DSL to a pure Lambda Calculus term. 302 | -- This is very confusing on its form and should be refactored for better readability. 303 | toLambda :: Caramel -> L.Term 304 | toLambda term = go term (M.empty :: M.Map String Int) 0 where 305 | go = fold lam app var num lst tup chr str wrd adt leT 306 | 307 | lam vars body = foldr cons body vars where 308 | cons var body scope depth = L.Lam (body (M.insert var depth scope) (depth+1)) 309 | 310 | leT defs term = foldr cons term defs where 311 | cons (name,vars,body) term scope depth = L.App (L.Lam (term (M.insert name depth scope) (depth+1))) (foldr cons' body vars scope depth) 312 | cons' var body scope depth = L.Lam (body (M.insert var depth scope) (depth+1)) 313 | 314 | app args scope depth = foldl1' snoc args scope depth where 315 | snoc left right scope depth = L.App (left scope depth) (right scope depth) 316 | 317 | var name scope depth = L.Var (depth - index - 1) where 318 | index = maybe (error ("undefined variable `"++name++"`.")) id (M.lookup name scope) 319 | 320 | num n scope depth = L.Lam (L.Lam (call n (L.App (L.Var 1)) (L.Var 0))) 321 | 322 | lst terms scope depth = L.Lam (L.Lam (foldr (\ h t -> L.App (L.App (L.Var 1) (h scope (depth+2))) t) (L.Var 0) terms)) 323 | 324 | tup terms scope depth = L.Lam (foldl (\ t h -> L.App t (h scope (depth+1))) (L.Var 0) terms) 325 | 326 | chr c scope depth = (L.Lam (foldr bits (L.Var 0) (numToBoolList 8 (fromEnum c)))) 327 | where bits bit expr = L.App expr (if bit then bit1 else bit0) 328 | 329 | str s scope depth = toLambda (Lst (map Chr s)) 330 | 331 | wrd c scope depth = (L.Lam (foldr bits (L.Var 2) (numToBoolList 32 (fromEnum c)))) 332 | where bits bit expr = L.App expr (if bit then bit1 else bit0) 333 | 334 | adt ctors scope depth = L.Lam (L.App (L.Var 0) (list (map ctor ctors))) where 335 | -- ctor (name,ctor) = pair (toLambda (Str name)) (applyConstToBoundVar (L.Lam (list (map field ctor)))) 336 | -- field (name,field) = pair (toLambda (Str name)) (L.App (field (M.insert "*" (depth+4) scope) (depth+8)) (L.Var 7)) 337 | 338 | ctor (name,ctor) = pair (toLambda (Str name)) (list (map field ctor)) 339 | field (name,field) = pair (toLambda (Str name)) (applyConstToBoundVar (L.Lam (L.App field' (L.Var 7)))) 340 | where field' = field (M.insert "#" (depth+7) scope) (depth+8) 341 | -- field (name,field) = pair (toLambda (Str name)) (L.App (field (M.insert "*" (depth+3) scope) (depth+7)) (L.Var 6)) 342 | 343 | list term = L.Lam (L.Lam (foldr (\ h t -> L.App (L.App (L.Var 1) h) t) (L.Var 0) term)) 344 | pair a b = L.Lam (L.App (L.App (L.Var 0) a) b) 345 | applyConstToBoundVar term = L.fold lam app var term (-1) where 346 | lam body depth = L.Lam (body (depth+1)) 347 | app left right depth = L.App (left depth) (right depth) 348 | var index depth | index == depth = L.Lam (L.Var (index+1)) 349 | var index depth | otherwise = L.Var index 350 | 351 | bit0 = L.Lam (L.Lam (L.Var 1)) 352 | 353 | bit1 = L.Lam (L.Lam (L.Var 0)) 354 | 355 | --Internal utility function for toLambda 356 | numToBoolList :: Int -> Int -> [Bool] 357 | numToBoolList 0 _ = [] 358 | numToBoolList s 0 = False : numToBoolList (s-1) 0 359 | numToBoolList s n = (mod n 2 == 1) : numToBoolList (s-1) (div n 2) 360 | 361 | -- Returns a list of the free variables in a Caramel term. 362 | freeVars :: Caramel -> [String] 363 | freeVars term = fold lam app var nat lst tup chr str wrd adt leT term S.empty where 364 | lam vars body boundVars = body (foldr S.insert boundVars vars) 365 | app terms boundVars = concatMap ($ boundVars) terms 366 | var varName boundVars = if S.member varName boundVars then [] else [varName] 367 | nat _ boundVars = [] 368 | lst terms boundVars = concatMap ($ boundVars) terms 369 | tup terms boundVars = concatMap ($ boundVars) terms 370 | chr _ boundVars = [] 371 | str _ boundVars = [] 372 | wrd _ boundVars = [] 373 | adt ctors boundVars = concatMap (concatMap (($ boundVars) . snd) . snd) ctors 374 | leT defs term boundVars 375 | = term (foldr S.insert boundVars (map (\ (name,_,_) -> name) defs)) 376 | ++ concatMap (\ (_,vars,body) -> body (foldr S.insert boundVars vars)) defs 377 | 378 | -- Sorts let expressions so that a term that depends on the other always come before. 379 | -- Also adds an extra bound variable for recursive terms, in order to enable further use 380 | -- with fixed-point combinators and similars, i.e., 381 | -- `sum n = (is_zero? n 0 (add n (sum (pred n 1))))` becomes 382 | -- `sum sum n = (is_zero? n 0 (add n (sum (pred n 1))))` 383 | -- So it can be used as `(Y sum 3)` (`Y` being the Y-combinator). 384 | sortRecursiveLets :: Caramel -> Caramel 385 | sortRecursiveLets = fold Lam App Var Nat Lst Tup Chr Str Wrd Adt leT where 386 | leT defs term = Let (sortTopologically (map node defs)) term where 387 | names = S.fromList (map (\ (name,_,_) -> name) defs) 388 | node def@(name, vars, body) = (name, dependencies, defWithFixedPoint) where 389 | dependencies = filter (/= name) . filter (flip S.member names) $ freeVars' 390 | defWithFixedPoint = (name, if elem name freeVars' then name:vars else vars, body) 391 | freeVars' = freeVars (Lam vars body) 392 | -- Naive implementation of a topological sort, O(N^2). Potential bottleneck. TODO: improve. 393 | sortTopologically :: [(String, [String], a)] -> [a] 394 | sortTopologically graph = go graph (S.empty :: S.Set String) [] where 395 | go :: [(String, [String], a)] -> S.Set String -> [(String, [String], a)] -> [a] 396 | go [] defined [] = [] 397 | go [] defined rest = go rest defined [] 398 | go ((node@(id, deps, val)) : nodes) defined rest 399 | | all (flip S.member defined) deps = val : go nodes (S.insert id defined) rest 400 | | otherwise = go nodes defined (node:rest) 401 | 402 | -- Evaluates a Caramel term by converting it to the Lambda Calculus, reducing and reading back. 403 | reduce :: Caramel -> Caramel 404 | reduce = fromLambda . L.reduce . toLambda 405 | -------------------------------------------------------------------------------- /src/Lambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, GADTs, FlexibleInstances, ScopedTypeVariables #-} 2 | 3 | -- Simple implementation of the Lambda Calculus. 4 | 5 | module Lambda where 6 | 7 | import qualified Data.IntMap as IM 8 | 9 | -- The datatype of Lambda Calculus terms. 10 | data Term 11 | = Lam !Term 12 | | App !Term !Term 13 | | Var !Int 14 | deriving (Show,Eq,Ord) 15 | 16 | -- HOAS term for normalization. 17 | data HOAS a 18 | = HPure a 19 | | HLam (HOAS a -> HOAS a) 20 | | HApp (HOAS a) (HOAS a) 21 | 22 | -- Folds over a term. 23 | fold :: (t -> t) -> (t -> t -> t) -> (Int -> t) -> Term -> t 24 | fold lam app var term = go term where 25 | go (Lam body) = lam (go body) 26 | go (App left right) = app (go left) (go right) 27 | go (Var idx) = var idx 28 | 29 | -- Folds over a term with scoped/named variables (using Int names). 30 | foldScoped :: (Int -> t -> t) -> (t -> t -> t) -> (Int -> t) -> Term -> t 31 | foldScoped lam app var term = fold lam' app' var' term 0 where 32 | lam' body depth = lam depth (body (depth+1)) 33 | app' left right depth = app (left depth) (right depth) 34 | var' idx depth = var (depth-1-idx) 35 | 36 | -- Pretty prints a term. 37 | pretty :: Term -> String 38 | pretty (Var n) = show n 39 | pretty (Lam a) = "λ"++pretty a 40 | pretty (App a b) = "("++pretty a++" "++pretty b++")" 41 | 42 | -- Reduces a strongly normalizing term to normal form. 43 | -- Does not halt then the term isn't strongly normalizing. 44 | reduceNaive :: Term -> Term 45 | reduceNaive (Lam a) = Lam (reduceNaive a) 46 | reduceNaive (Var a) = Var a 47 | reduceNaive (App a b) = case reduceNaive a of 48 | Lam body -> reduceNaive (subs (reduceNaive b) True 0 (-1) body) 49 | otherwise -> App (reduceNaive a) (reduceNaive b) 50 | where 51 | subs t s d w (App a b) = App (subs t s d w a) (subs t s d w b) 52 | subs t s d w (Lam a) = Lam (subs t s (d+1) w a) 53 | subs t s d w (Var a) 54 | | s && a == d = subs (Var 0) False (-1) d t 55 | | otherwise = Var (a + (if a > d then w else 0)) 56 | 57 | -- Reduces a term to normal form through the host language. 58 | reduce :: Term -> Term 59 | reduce = reduceHOAS . toHOAS where 60 | 61 | -- Converts a term to a HOAS term. 62 | toHOAS :: forall a . Term -> HOAS a 63 | toHOAS term = go term IM.empty 0 where 64 | go :: Term -> IM.IntMap (HOAS a) -> Int -> HOAS a 65 | go (App a b) vars depth = applyHOAS (go a vars depth) (go b vars depth) 66 | go (Lam a) vars depth = HLam $ \ var -> go a (IM.insert depth var vars) (depth+1) 67 | go (Var i) vars depth = vars IM.! (depth-1-i) 68 | 69 | -- Applies a HOAS term to another. 70 | applyHOAS :: HOAS a -> HOAS a -> HOAS a 71 | applyHOAS (HLam a) b = a b 72 | applyHOAS a b = HApp a b 73 | 74 | -- Reduces a HOAS term to the corresponding Term in normal form. 75 | reduceHOAS :: HOAS Int -> Term 76 | reduceHOAS = go 0 where 77 | go depth (HPure i) = Var (depth-1-i) 78 | go depth (HLam a) = Lam (go (depth+1) (a (HPure depth))) 79 | go depth (HApp a b) = App (go depth a) (go depth b) 80 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | import Caramel 2 | import Control.Applicative 3 | import Control.Monad (when) 4 | import Data.List 5 | import Data.List.Split (splitOn) 6 | import System.Directory 7 | import System.Environment 8 | import System.Exit 9 | import qualified Lambda as L 10 | import qualified Transmogrifier as T 11 | 12 | main = do 13 | dir <- getCurrentDirectory 14 | fileNames <- fmap (filter (".mel" `isSuffixOf`)) (getDirectoryContents dir) 15 | contents <- fmap concat (mapM readFile fileNames) 16 | args <- getArgs 17 | when (null args) $ do 18 | putStrLn $ unlines [ 19 | "Usage:", 20 | " mel term_name # Evaluates term_name and prints the result on the Caramel syntax.", 21 | " mel term_name.lam # Evaluates term_name and prints the result on the Lambda Calculus.", 22 | "You must be in a directory with a `.mel` file containing the `term_name` definition.", 23 | "Visit http://github.com/maiavictor/caramel for more info."] 24 | exitFailure 25 | let symbolFile = head args 26 | let (symbolName:symbolFormat:_) = splitOn "." symbolFile ++ ["mel"] 27 | let source = symbolName ++ "\n" ++ (unlines . map (" " ++) . lines $ contents) 28 | let result = sortRecursiveLets $ parse source 29 | let reduce = if last symbolFormat == '!' then L.reduceNaive else L.reduce 30 | let format = case filter (/= '!') symbolFormat of 31 | "lam" -> L.pretty . reduce . toLambda 32 | "lam?" -> L.pretty . toLambda 33 | "js" -> T.toJavaScript . reduce . toLambda 34 | "scm" -> T.toScheme . reduce . toLambda 35 | "scm?" -> T.toScheme . toLambda 36 | "lua" -> T.toLua . reduce . toLambda 37 | "hs" -> T.toHaskell . reduce . toLambda 38 | "py" -> T.toPython . reduce . toLambda 39 | "rb" -> T.toRuby . reduce . toLambda 40 | "opt" -> T.toOptlam . reduce . toLambda 41 | "blc" -> T.toBinaryLambdaCalculus . reduce . toLambda 42 | "blc?" -> T.toBinaryLambdaCalculus . toLambda 43 | "ast" -> T.toAst . reduce . toLambda 44 | "mel?" -> pretty . fromLambda . toLambda 45 | otherwise -> pretty . fromLambda . reduce . toLambda 46 | putStrLn (format result) 47 | -------------------------------------------------------------------------------- /src/Transmogrifier.hs: -------------------------------------------------------------------------------- 1 | -- Compiles a λ-calculus program to anything. 2 | 3 | module Transmogrifier where 4 | 5 | import Lambda 6 | import Util 7 | 8 | transmogrify :: (String -> String -> String) -> (String -> String -> String) -> Term -> String 9 | transmogrify lam app = foldScoped (lam.(infiniteAlphabet!!)) app (\ index -> infiniteAlphabet!!index) 10 | 11 | toJavaScript :: Term -> String 12 | toJavaScript = transmogrify lam app where 13 | lam var body = "(function("++var++"){return "++body++"})" 14 | app left right = left ++ "(" ++ right ++ ")" 15 | 16 | toPython :: Term -> String 17 | toPython = transmogrify lam app where 18 | lam var body = "(lambda "++var++": "++body++")" 19 | app left right = left++"("++right++")" 20 | 21 | toScheme :: Term -> String 22 | toScheme = transmogrify lam app where 23 | lam var body = "(lambda("++var++")"++body++")" 24 | app left right = "("++left++" "++right++")" 25 | 26 | toHaskell :: Term -> String 27 | toHaskell term = "(let (#) = unsafeCoerce in " ++ transmogrify lam app term ++")" where 28 | lam var body = "(\\"++var++"->"++body++")" 29 | app left right = "("++left++"#"++right++")" 30 | 31 | toLua :: Term -> String 32 | toLua = transmogrify lam app where 33 | lam var body = "(function ("++var++") return "++body++" end)" 34 | app left right = left ++ "(" ++ right ++ ")" 35 | 36 | toRuby :: Term -> String 37 | toRuby = transmogrify lam app where 38 | lam var body = "(->("++var++"){"++body++"})" 39 | app left right = left ++ ".(" ++ right ++ ")" 40 | 41 | toOptlam :: Term -> String 42 | toOptlam = fold lam app var where 43 | lam body = "L("++body++")" 44 | app left right = "A("++left++","++right++")" 45 | var index = "V("++show index++")" 46 | 47 | toBinaryLambdaCalculus :: Term -> String 48 | toBinaryLambdaCalculus = fold lam app var where 49 | lam body = "00" ++ body 50 | app left right = "01" ++ left ++ right 51 | var index = replicate (index+1) '1' ++ "0" 52 | 53 | toAst :: Term -> String 54 | toAst = fold lam app var where 55 | lam body = "Lam(" ++ body ++ ")" 56 | app left right = "App(" ++ left ++ "," ++ right ++ ")" 57 | var index = "Var(" ++ show index ++ ")" 58 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Util where 4 | 5 | import Control.Monad (replicateM) 6 | 7 | -- Infinite list of all strings consisting of upper/lowercase letters. 8 | infiniteAlphabet :: [String] 9 | infiniteAlphabet = do 10 | x <- [1..] 11 | replicateM x (['a'..'z']++['A'..'Z']) 12 | 13 | -- Calls a function `n` times. 14 | call :: (Num a, Eq a) => a -> (t -> t) -> t -> t 15 | call n f x = go n x where 16 | go !0 !x = x 17 | go !k !x = go (k-1) (f x) 18 | {-# INLINE call #-} 19 | --------------------------------------------------------------------------------