├── .gitignore ├── Makefile ├── README.md ├── Setup.hs ├── core_examples ├── fib.rfun ├── ifl_progs.rfun ├── inc.rfun ├── list.rfun ├── myprog.rfun ├── newSyntax.rfun ├── pack.rfun ├── plus.rfun ├── programs.rfun ├── self.rfun ├── selfInterp.rfun ├── selfInterp_loop.rfun ├── tm.rfun └── treeRank.rfun ├── examples └── basic.rfun ├── mkdocs.yml ├── rfun-interp.cabal └── src ├── Ast.hs ├── Core ├── Ast.hs ├── Interp.hs ├── Parser.hs ├── Preparse.hs └── RFun2Prog.hs ├── Interp.hs ├── MainCore.hs ├── MainRFun.hs ├── MainWeb.hs ├── Makefile ├── Parser.hs ├── PrettyPrinter.hs └── TypeCheck.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | 13 | src/Main 14 | 15 | docs/* 16 | site 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | FILES=src/Main.hs src/Jana/*.hs 2 | 3 | all: 4 | (cd src; make opt) 5 | 6 | web: 7 | (cd src; make web) 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # RFun: A reversible functional programming language 2 | 3 | This is a tutorial that introduces the reversible functional RFun. More specifically, this tutorial describes RFun version 2. It is intended to give a good overview of the language and make the reader able to start writing their own programs. 4 | 5 | It is not intended to give a detailed formalisation of RFun, and for this we refer to the references. Also we do not give any background of reversible computations nor any motivation for looking it at the first place; for this we will refer to [...]. 6 | 7 | **Note** also that RFun is being actively developed. It is therefore expected that the language will change over time. Also, though the type checker is (mostly) sound, it is by fra complete. The interpretation, however, is both which makes is a langauge you can play with. If you find the language interesting, you can also participate in further development. 8 | 9 | ## History 10 | 11 | RFun was first introduces in 2013 by Holger Bock Axelsen, Tetsuo Yokoyama and Robert Glück [1]. It was introduced as a simple reversible untyped first-order functional language, and focused on the theoretical foundation and formal semantics. It is also noteworthy to add that the language is R-Turing complete; i.e. Turing complete with the restriction to reversible programs. 12 | 13 | Later work by Michael Kirkedal Thomsen and Holger Bock Axelsen [2] detailed how RFun was implemented and what to consider when developing programs. This work also added much syntactic sugar to make it easier to program. Finally we added higher-order functions so that functions like `map` could be implemented. 14 | 15 | This second version of RFun can be credited to two events. Firstly, much follows from the work in [2]. It was the first time that larger programs were developed in RFun and it gave much insight to what needed to be improved. Secondly, it can be credited to the Training School on Reversible Computation held in Toruń. When teaching a language to 20+ students you have to move it from a simple proof-of-concept to one that can be easily understood. 16 | 17 | The first version of RFun is very basic and properties of the languages have been (more easily) shown. It is therefore used as the target language for the later version of RFun. We will, thus, refer to the first version as RFun\_core while the later is just called RFun. 18 | 19 | 20 | ## Running RFun programs 21 | You get the source code for the latest version of the RFun interpreter by contacting Michael Kirkedal Thomsen (). It is currently held at a private repository. 22 | 23 | The source code for an RFun\_core interpreter (developed for [2]) can be found at: 24 | 25 | * 26 | 27 | Alternatively, you can also use our online interpreter, which is available at: 28 | 29 | * 30 | 31 | 32 | ## Simple Example 33 | 34 | For historical reasons the Fibonacci function has always been used as a _Hello World_ program for reversible languages. There is no reason to change this so here it is: 35 | 36 | ```haskell 37 | fib :: Nat <-> (Nat, Nat) 38 | fib Z = ((S Z),(S Z)) 39 | fib (S m) = 40 | let (x,y) = fib m 41 | y' = plus x y 42 | in (y',x) 43 | ``` 44 | 45 | Now you have seen some code. For functional programmers, it will look familiar (have drawn inspiration from Haskell), but some parts are new. We will explain some details of the language below. 46 | 47 | ## Important concepts 48 | Before we understand how to make programs, we need to understand a few central concepts. 49 | 50 | ### Linearity 51 | The theory behind linear types stems back from linear logic. It is basically a way to ensure that resources are only used once. Then we will stretch it even further to make sure that resources are used exactly once. 52 | 53 | In the Fibonacci function, for example, you can see that the variable `m` is introduced on the left-hand side and used only (and precisely) in the recursive call to `fib`. This is the same for `y` and `y'`; you should also consider returning `y'` as a usage. 54 | 55 | ### Ancillae 56 | Ancillae (or ancillary variables) is a term that has been adapted from physics and describes a state in which entropy is unchanged. Here we specifically use it for variables for which we can _guarantee_ that their values are unchanged over a function call. We cannot put too little emphasis on the _guarantee_, because we have taken a conservative approach and will only use it when we statically can ensure that it is upheld. 57 | 58 | You might have noted that I left out the `x` variable of the Fibonacci function. If you look closely you can see that (in opposition to the other variables) it occurs three times. First, it is introduced by the recursive call to `fib`, then it is used by the plus function, and, finally, it is returned. Of these `plus` is actually using it as an ancilla; it has read and used the value for something, but we are guaranteed that the same value is restored after the call. This is not the case for `y`, which is the reason that we introduce the new `y'`. 59 | 60 | ### First-match policy 61 | The last concept we will introduce is the first-match policy (FMP), which is necessary to guarantee injectivity of functions. Conceptually it states that the result of a function must not be the result of any previous branches; knowing nothing about the possible content of variables. 62 | 63 | Often you can check this statically based on type definitions (which we currently do not do), but in some cases we can only do it at run-time. In the Fibonacci example there is no simple analysis that can check if the FMP is upheld; we would need a side-condition referring to the development of Fibonacci numbers. Thus, we can only rely on a run-time check. We will soon see examples where the FMP has a static guarantee. 64 | 65 | ## Examples 66 | Let's look at some examples to get a better understanding of RFun. 67 | 68 | ### Natural number arithmetic 69 | 70 | Natural numbers encoded as Peano numbers are a built-in type of RFun. Natural numbers will here have the standard definition: 71 | 72 | ``` 73 | data Nat = Z | (S Nat) 74 | ``` 75 | 76 | Specific natural numbers can also be written as literals. 77 | 78 | The first interesting operation we can define over our natural numbers is the increment function. First we declare its type: 79 | 80 | ``` 81 | inc :: Nat <-> Nat 82 | ``` 83 | 84 | This declares `inc` to be a function that given a `Nat` returns a `Nat`. Though RFun has many similarities with other functional languages (the type signature is inspired by Haskell) the usage of `<->` and not `->` is important. Using `f :: a <-> b` we define `f` to be a function that consumes an input of type `a` and returns an output of type `b`. Here "consumes" should be taken literally: to ensure reversibility, all information of `a` must be transformed and _conserved_ into `b`. 85 | 86 | We can now move onto defining the increment function as 87 | 88 | ``` 89 | inc :: Nat <-> Nat 90 | inc n = (S n) 91 | ``` 92 | 93 | We see here that our left-hand-side variable `n` occurs once on the right-hand side, which means that linearity is upheld. 94 | 95 | As we now have the increment function we can move onto defining the decrement function. In a normal language we would do this in the standard way as 96 | 97 | ``` 98 | dec :: Nat <-> Nat 99 | dec (S n) = n 100 | ``` 101 | 102 | However, we know that decrementing is the symmetrical inverse of incrementing, so given that we have a reversible language we can define this using a reverse interpretation of the forward call, thus 103 | 104 | ``` 105 | dec :: Nat <-> Nat 106 | dec n = inc! n 107 | ``` 108 | Note that the "!" at the end of the function indicates that the function is executed in reverse. 109 | 110 | Granted, these are not the most interesting functions, but we now have a first grasp of the language. From this we can now move onto more interesting functions, so let's look at addition. Firstly, it is important to remember that addition in reversible computation is not defined as the normal `+(a, b) = a + b`, but instead is embedded as `+(a, b) = (a, a + b)`. In other words, not only do we need to calculate the sum of the two numbers, we must also leave one of the numbers unchanged. 111 | 112 | So let's define the type for our `plus` function. A first attempt could be 113 | 114 | ``` 115 | plus :: (Nat, Nat) <-> (Nat, Nat) 116 | ``` 117 | 118 | The above matches perfectly the above understanding, that plus takes a pair of `Nat`s and returns another pair of `Nat`s. However, we do actually have more information than this: we also know that the value of one of the numbers is unchanged. We can include this information in our type signatures as 119 | 120 | ``` 121 | plus :: Nat -> Nat <-> Nat 122 | ``` 123 | 124 | Here `plus` is defined as a function that takes one `Nat` that must be unchanged over the computation (ancillary) and one `Nat` that is going to be transformed into another `Nat`. That the first `Nat` is unchanged is something we must ensure in our computation. Note that `<->` binds stronger than `->`. So how can we define such a function? Well, it looks much like the normal implementation: 125 | 126 | ``` 127 | plus :: Nat -> Nat <-> Nat 128 | plus Z x = x 129 | plus (S y) x = 130 | let x' = plus y x 131 | in (S x') 132 | ``` 133 | 134 | So how do we know that the first argument is unchanged? This actually follows from simple structural induction. In the base clause we know that the first argument is a basic constructor term (you can look at it as constant) and it is therefore guaranteed to be unchanged. 135 | In the recursive clause we have (by the induction hypothesis) that `y` is unchanged over the recursive call and as this is the only usage of `y` we can always reconstruct the input `(S y)` and thus the first argument is unchanged. 136 | 137 | This argument here was a bit handwaving, but given the type signature and the abstract syntax, we can easily check this construction. 138 | 139 | Using a simple program transformation we can actually transform our `plus` function into a paired version of addition that matches out initial type signature. 140 | 141 | ``` 142 | plusP :: (Nat, Nat) <-> (Nat, Nat) 143 | plusP (Z, x) = (Z, x) 144 | plusP ((S y), x) = 145 | let (y', x') = plusP (y, x) 146 | in ((S y'), (S x')) 147 | ``` 148 | 149 | Here we only 150 | 151 | * wrap our input into a tuple, 152 | * add the ancillary arguments to all output leaves, 153 | * wrap all function calls into tuples, 154 | * add the ancillary inputs to function calls to the output. 155 | 156 | Note that copying of ancillary arguments seemingly destroys referential transparency, however, due to linearity the reintroduction of `y` does not overwrite the value in `y` as the value was previously consumed. 157 | 158 | ### List functions 159 | 160 | Lists are the third and final built-in data type of RFun and from a functional perspective very interesting. We will start by defining the favourite `map` function. 161 | 162 | ``` 163 | map :: (a <-> b) -> [a] <-> [b] 164 | ``` 165 | 166 | The type signature tells us that `map` is a function that given a function (which will not be changed) that transforms an input of type `a` to an output of type `b` will tranform a list of `a`s to a list of `b`s. 167 | 168 | ``` 169 | map :: (a <-> b) -> [a] <-> [b] 170 | map fun [] = [] 171 | map fun (x : xs) = 172 | let x' = fun x 173 | xs' = map fun xs 174 | in (x' : xs') 175 | ``` 176 | 177 | Given the application of the function referenced by `fun` it is clear (by induction) that `fun` is unchanged and only the input is transformed to the output. Personally, I find it surprising how closely this models the normal definition. 178 | 179 | The next function we can look at is `length`, which returns the length of a list. Before starting an implementation, we should think about what we are doing. The length of a list is one of several pieces of information that is held in a list: the other ones are the element values and the order of the elements. It is therefore obvious that we cannot make a function which merely transforms a list of some type into its length. The approach that we will use here is instead that the length is a property of the list that we will extract, while keeping the list unchanged. 180 | 181 | ``` 182 | length :: [a] -> () <-> Nat 183 | ``` 184 | 185 | The `length` function is therefore defined as a function that given a list containing elements of any type, transforms no information (here represented by the empty tuple `()`) into a `Nat`. From this it is obvious that the information contained in the `Nat` has been copied from the list. This type also comprises what we would call a _Bennett embedding_ of the normal `length` function. 186 | 187 | ``` 188 | length :: [a] -> () <-> Nat 189 | length [] () = Z 190 | length (x : xs) () = 191 | let n = length xs () 192 | in (S n) 193 | ``` 194 | 195 | Based on this type, we have an implementation of `length` that closely resembles the normal implementation. 196 | 197 | Finally we would like to implement an efficient (linear run-time) version of list reversal. We have a reversible language, so that should be easy. Right! 198 | 199 | The simple normal version would use an `append` function to move the first element to the last. This is however not efficient. A better implementation would use a helper function with an accumulator to which one element is moved at a time. This is the version we would implement. 200 | 201 | ``` 202 | reverse :: [a] <-> [a] 203 | reverse xs = 204 | let xs_s = length xs () 205 | ([], ys) = move xs_s (xs, []) 206 | () = length! ys xs_s 207 | in ys 208 | end 209 | 210 | move :: Nat -> ([a], [a]) <-> ([a], [a]) 211 | move Z (x, l) = (x, l) 212 | move (S s) ((x:xs), l) = 213 | let xs' = move s (xs, (x:l)) 214 | in xs' 215 | end 216 | ``` 217 | However, the first-match policy complicates matters a bit. Here the accumulator version is implemented as the `move` function, which takes a `Nat` and moves this many elements from one list to another. Note, the difference to the conventional accumulator version that moves all elements. 218 | 219 | `reverse` is them implemented by finding the length of a list, moving this many elements from the input list to a list that will serve as the output, then uncomputing the length again. 220 | 221 | ## Equality and Duplication 222 | 223 | Equality (and duplication) have a special place in FRun. First, there exists a predefined data constructor for equality testing, which has the following definition: 224 | 225 | ``` 226 | data EQ = Eq | Neq a 227 | ``` 228 | 229 | Furthermore, there exists a predefined function that performs equality testing. It is a special function with the following type: 230 | 231 | ``` 232 | eq :: a -> a <-> EQ 233 | ``` 234 | 235 | Given two values, say `eq x y`, the first argument (`x`) is ancillary, so we know that it will be unchanged. The second argument (`y`), however, will be transformed into a value of the `EQ` type, where the result is 236 | 237 | * `Eq` if `x` is equal to `y` 238 | * `Neq y` if `x` is different from `y`. 239 | 240 | Note, thus, that testing for equality can destroy one copy of the two values. I will not give an implementation of `eq` as it is not possible in RFun. 241 | 242 | Based on `eq` we can then make a duplication function by inverse execution: 243 | 244 | ``` 245 | dup :: a -> () <-> a 246 | dup x () = eq! x Eq 247 | ``` 248 | 249 | ## Semantics 250 | The semantics of RFun is defined over a translation to RFun\_core. There is no formal definition of the semantics and I will here not go into details about the translation. Most translations are quite straightforward. _Be warned_ that since the semantics is defined over a translation to RFun\_core, you can see quite obscure run-time errors returned from the interpretation of RFun\_core. This will be improved in the future. 251 | 252 | RFun\_core does have a formal semantics, which can be found in [1]. 253 | 254 | 255 | # References 256 | 257 | [1] T. Yokoyama and H. B. Axelsen and R. Gluck, Towards a reversible functional language, Reversible Computation, RC '11, 7165 14--29 (2012) 258 | 259 | [2] M. K. Thomsen and H. B. Axelsen, Interpretation and Programming of the Reversible Functional Language RFUN, Proceedings of the 27th Symposium on the Implementation and Application of Functional Programming Languages, 8:1--8:13 (2016) 260 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /core_examples/fib.rfun: -------------------------------------------------------------------------------- 1 | fib Z =^= {S(Z),S(Z)} 2 | fib S(m) =^= 3 | let {x,y} = fib m 4 | in plus {y,x} 5 | 6 | plus { x, Z } =^= {x, Z} 7 | plus { x, S(y)} =^= 8 | let {x',y'} = plus {x,y} 9 | in {S(x'), S(y')} 10 | -------------------------------------------------------------------------------- /core_examples/ifl_progs.rfun: -------------------------------------------------------------------------------- 1 | -- EXAMPLES FOR IFL'15 PRESENTATION -- 2 | 3 | ----------------------------- 4 | -- Arithmetic functions 5 | ----------------------------- 6 | 7 | -- data Peano = Z | S(Peano) 8 | 9 | inc x =^= S(x) 10 | 11 | -- with check for Peano number 12 | incP Z =^= S(Z) 13 | incP S(x) =^= 14 | let x' = incP x 15 | in S(x') 16 | 17 | -- decrement as reverse call 18 | dec n =^= 19 | rlet n = inc n' 20 | in n' 21 | 22 | -- Input example: {2,4} 23 | plus { Z , y} =^= |{y}| 24 | plus {S(x), y} =^= 25 | let {x',y'} = plus {x,y} 26 | in {S(x'), y'} 27 | 28 | plusA { x, Z } =^= {x, Z} 29 | plusA { x, S(y)} =^= 30 | let {x',y'} = plusA {x,y} 31 | in {S(x'), S(y')} 32 | 33 | 34 | ----------------------------- 35 | -- List functions 36 | ----------------------------- 37 | zip {[],[]} =^= [] 38 | zip {(x:xs),(y:ys)} =^= 39 | let zs = zip {xs, ys} 40 | in ({x,y}:zs) 41 | 42 | length [] =^= {Z,[]} 43 | length (x : xs) =^= 44 | let {l, xs'} = length xs 45 | in {S(l), (x : xs')} 46 | 47 | rev [] =^= [] 48 | rev (x:xs) =^= 49 | let xs' = rev xs 50 | rlet {xs',x} = last xs'' 51 | in xs'' 52 | 53 | last ([x]) =^= {[],x} 54 | last (x:xs) =^= 55 | let {xs',l} = last xs 56 | in {(x:xs'),l} 57 | 58 | reverse xs =^= 59 | let {xs_s, xs'} = length xs 60 | {[], ys, xs_s'} = move {xs', [], xs_s} 61 | rlet {xs_s', ys} = length ys' 62 | in ys' 63 | 64 | move { x , l, Z } =^= {x, l, Z} 65 | move {(x:xs), l, S(s)} =^= 66 | let {ys, ls, s'} = move {xs,(x:l),s} 67 | in {ys, ls, S(s')} 68 | 69 | -- Input example: {inc, [1,2,3]} 70 | map {fun, [] } =^= {fun, []} 71 | map {fun, (x:xs)} =^= 72 | let x' = fun x 73 | {fun', xs'} = map {fun, xs} 74 | in {fun', (x':xs')} 75 | 76 | foldl {fun, i, []} =^= {fun,i,[]} 77 | foldl {fun, i, (x:xs)} =^= 78 | let {i', x'} = fun {i, x} 79 | {fun', i'', xs'} = foldl {fun, i', xs} 80 | in {fun', i'', (x' : xs')} 81 | 82 | scanl {fun, i, []} =^= {fun, i, []} 83 | scanl {fun, i, (x:xs)} =^= 84 | let {x', i'} = fun {x, i} 85 | {fun', x'', xs'} = scanl {fun, x', xs} 86 | in {fun', i', (x'' : xs')} 87 | -------------------------------------------------------------------------------- /core_examples/inc.rfun: -------------------------------------------------------------------------------- 1 | -- Simple implementation of incrementation of a Peano number 2 | inc x =^= S(x) 3 | 4 | -- "Type-safe" implementation ensuring that input/output is a Peano number 5 | incP Z =^= S(Z) 6 | incP S(np) =^= 7 | let npp = incP np 8 | in S(npp) 9 | -------------------------------------------------------------------------------- /core_examples/list.rfun: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------- 2 | ---- LIST TRANSFORMATION 3 | --------------------------------------------------------------- 4 | 5 | -- module List ( 6 | -- zip, unzip, 7 | -- scanr, scanr1, scanl, scanl1, 8 | -- foldr, foldr1, foldl, foldl1 9 | -- map, 10 | -- reverse, 11 | -- splitAt, hdtl, last, 12 | -- length, 13 | -- append, unAppend, 14 | -- replicate, intersperse, interleave, transpose, subsequences,permutations, 15 | -- group, tails, inits 16 | -- ) where 17 | 18 | -- |Zip 19 | zip {[],[]} =^= [] 20 | zip {(x:xs),(y:ys)} =^= 21 | let zs = zip {xs, ys} 22 | in ({x,y}:zs) 23 | 24 | -- |Unzip 25 | unzip v =^= rlet v = zip v' in v' 26 | 27 | -- scanr applying function given in fun 28 | scanr {fun, i, []} =^= {fun, i, []} 29 | scanr {fun, i, (x:xs)} =^= 30 | let {i', x'} = fun {i, x} 31 | {fun', x'', l} = scanr {fun, x', xs} 32 | in {fun', i', (x'' : l)} 33 | 34 | scanr1 {fun, []} =^= {fun, []} 35 | scanr1 {fun, (x:xs)} =^= 36 | let {fun', x', xs'} = scanr {fun,x,xs} 37 | in {fun', (x':xs')} 38 | 39 | -- scanl applying function given in fun 40 | scanl {fun, i, []} =^= {fun, i, []} 41 | scanl {fun, i, [x]} =^= 42 | let {i', x'} = fun {i, x} 43 | in {fun, i', [x']} 44 | scanl {fun, i, (x : z : xs)} =^= 45 | let {fun', i', (y:ys)} = scanl {fun, i, (z : xs)} 46 | {y', x'} = fun' {y, x} 47 | in {fun', i', (x' : y' : ys)} 48 | 49 | scanl1 {fun, []} =^= {fun, []} 50 | scanl1 {fun, (x:xs)} =^= 51 | let ys = reverse (x:xs) 52 | in scanr1 {fun,ys} 53 | 54 | -- foldr applying function given in fun 55 | -- this is actually more similar to mapAccumR 56 | foldr {fun,x,[]} =^= {fun,x,[]} 57 | foldr {fun,x,(y:ys)} =^= 58 | let {y',x'} = fun {y,x} 59 | {fun', x'',ys'} = foldr {fun, x',ys} 60 | in {fun', x'', (y':ys')} 61 | 62 | foldr1 {fun, (x:xs)} =^= 63 | let {x',x''} = dupEq {x} 64 | {fun', y, xs'} = foldr {fun, x',xs} 65 | in {fun', y,(x'':xs')} 66 | 67 | 68 | -- foldl applying function given in fun 69 | -- this is actually more similar to mapAccumL 70 | foldl {fun,x,[]} =^= {fun,x,[]} 71 | foldl {fun,x,(y:ys)} =^= 72 | let {fun',x',ys'} = foldl {fun,x,ys} 73 | {y',x''} = fun' {y,x'} 74 | in {fun', x'', (y':ys')} 75 | 76 | foldl1 {fun,[x]} =^= 77 | let {x',x''} = dupEq {x} 78 | in {fun,x',[x'']} 79 | foldl1 {fun,(y:ys)} =^= 80 | let {fun',x,ys'} = foldl1 {fun, ys} 81 | {y',x'} = fun' {y,x} 82 | in {fun', x', (y':ys')} 83 | 84 | 85 | -- map applying the function given in fun 86 | map {fun, [] } =^= {fun, []} 87 | map {fun, (x : xs)} =^= 88 | let x' = fun x 89 | {fun', xs'} = map {fun, xs} 90 | in {fun', (x' : xs')} 91 | 92 | -- Reverse of a list 93 | reverse xs =^= 94 | let {xs_s, xs'} = length xs 95 | {[], ys, xs_s'} = move {xs', [], xs_s} 96 | rlet {xs_s', ys} = length ys' 97 | in ys' 98 | 99 | -- This function in only partial 100 | -- helper to reverse 101 | move { x , l, Z } =^= {x, l, Z} 102 | move {(x : xs), l, S(s)} =^= 103 | let {ys, ls, s'} = move {xs,(x:l),s} 104 | in {ys, ls, S(s')} 105 | 106 | -- splitAt is identical to the Haskell version 107 | splitAt { Z , l } =^= {[],l} 108 | splitAt {S(s), (l : ls)} =^= 109 | let {l1, l2} = splitAt {s, ls} 110 | in {(l : l1), l2} 111 | 112 | -- Finds the head and tail 113 | hdtl (x:xs) =^= {x,xs} 114 | 115 | -- Finds the last elements and the rest of the list 116 | last ([x]) =^= {[],x} 117 | last (x:xs) =^= 118 | let {xs',l} = last xs 119 | in {(x:xs'),l} 120 | 121 | 122 | -- If it is called reverse and the N is not equal 123 | -- to the length of the list, I will fail. 124 | length [] =^= {Z,[]} 125 | length (x : xs) =^= 126 | let {l, xs'} = length xs 127 | in {S(l), (x : xs')} 128 | 129 | -- append function 130 | append {[],l} =^= {[], l} 131 | append {(x : xs), l} =^= 132 | let {xs', l'} = append {xs, l} 133 | {x', x''} = dupEq {x} 134 | in {(x' : xs'), (x'' : l')} 135 | 136 | -- The reverse of the append 137 | unAppend x =^= 138 | rlet x = append x' 139 | in x' 140 | 141 | -- Identical to Haskell replicate function 142 | replicate {S(Z),x} =^= [x] 143 | replicate {S(n),x} =^= 144 | let {x',x''} = dupEq {x} 145 | xs = replicate {n,x'} 146 | in (x'':xs) 147 | 148 | -- Similar to Haskell intersperse function 149 | intersperse {x,[]} =^= {x,[]} 150 | intersperse {x,[y]} =^= {x,[y]} 151 | intersperse {x,(l:list)} =^= 152 | let {x',list'} = intersperse {x,list} 153 | {x'',xn} = dupEq {x'} 154 | in {x'',(l:xn:list')} 155 | 156 | -- Identical to Haskell transpose function 157 | transpose [] =^= [] 158 | transpose (x:xs) =^= 159 | let xs' = transpose xs 160 | in addToLists {x,xs'} 161 | 162 | -- Helper function for transpose 163 | -- Adds empty lists this second input is an empty list, e.g. addToLists {[1,2],[]} = [[1],[2]] 164 | addToLists {[],[]} =^= [] 165 | addToLists {(x:xs),[]} =^= 166 | let ys' = addToLists {xs, []} 167 | in (([x]):ys') 168 | addToLists {(x:xs),(y:ys)} =^= 169 | let ys' = addToLists {xs, ys} 170 | in ((x:y):ys') 171 | 172 | -- Identical to Haskell subsequences function 173 | subsequences [] =^= [[]] 174 | subsequences (x:xs) =^= 175 | let xs' = subsequences xs 176 | in duplicateAdd {x,xs'} 177 | 178 | -- Helper function for subsequences 179 | duplicateAdd {x,[y]} =^= 180 | let {y',y''} = dupEq {y} 181 | in [y',(x:y'')] 182 | duplicateAdd {x,(y:ys)} =^= 183 | let {x',x''} = dupEq {x} 184 | ys' = duplicateAdd{x',ys} 185 | {y',y''} = dupEq {y} 186 | in (y':(x'':y''):ys') 187 | 188 | -- Divide a list into n lists of size m 189 | divideOf {S(Z),m,xs} =^= 190 | rlet {m,xs} = length xs' 191 | in [xs'] 192 | divideOf {S(n),m,xs} =^= 193 | let {m',m''} = dupEq {m} 194 | {x,xs'} = splitAt {m', xs} 195 | xs'' = divideOf {n,m'',xs'} 196 | in (x:xs'') 197 | 198 | -- Divide a list into lists of size m 199 | divideSize {m,xs} =^= 200 | let {len,xs'} = length xs 201 | rlet {m,len} = mult {m',n} 202 | in divideOf {n,m',xs'} 203 | 204 | -- Finds all permutations of a list 205 | -- Does not give the same order as the Haskell version. 206 | permutations [] =^= [] 207 | permutations [x] =^= [[x]] 208 | permutations (x:xs) =^= 209 | let ys = permutations xs 210 | ys' = perms {x,ys} 211 | rlet ys' = divideSize {m,(y:ys'')} 212 | {m,y} = length y' 213 | in (y':ys'') 214 | 215 | -- Helper function for permutations 216 | perms {x,[y]} =^= 217 | let z = interleave {x,y} 218 | in [z] 219 | perms {x, (y:ys)} =^= 220 | let {x',x''} = dupEq {x} 221 | zs = perms {x',ys} 222 | z = interleave {x'',y} 223 | in (z:zs) 224 | 225 | -- Adds x to all possible positions in ys 226 | interleave {x,[]} =^= [[x]] 227 | interleave {x,(y:ys)} =^= 228 | let (z:zs) = interleave {x,ys} 229 | {(x':z'),z''} = dupEq {z} 230 | (z'':zs') = consToLists {y,(z':z'':zs)} 231 | in ((x':z''):zs') 232 | 233 | -- Adds x to the front of all lists in ys 234 | consToLists {x,[y]} =^= [(x:y)] 235 | consToLists {x, (y:ys)} =^= 236 | let {x',x''} = dupEq {x} 237 | ys' = consToLists {x',ys} 238 | in ((x'':y):ys') 239 | 240 | -- Identical to Haskell group function 241 | -- and not far from the run-length encoding 242 | group [] =^= [] 243 | group (x:xs) =^= 244 | case group xs of 245 | [] -> [[x]] 246 | ((y:ys):tail) -> 247 | case |{x,y}| of 248 | {x'} -> 249 | let {x'',y''} = dupEq {x'} 250 | in ((x'':y'':ys):tail) 251 | {x',y'} -> ([x']:(y':ys):tail) 252 | 253 | -- Equal to the Haskell tails function 254 | tails [] =^= [[]] 255 | tails (x:xs) =^= 256 | let {xs',xs''} = dupEq {xs} 257 | ys = tails xs' 258 | in ((x:xs''):ys) 259 | 260 | -- Equal to the Haskell inits function 261 | inits [] =^= [[]] 262 | inits (x:xs) =^= 263 | let ys = inits xs 264 | ys' = consToLists {x,ys} 265 | in ([]:ys') 266 | 267 | -------------------------------------------------------------------------------- /core_examples/myprog.rfun: -------------------------------------------------------------------------------- 1 | 2 | --data N = Z | S(n) 3 | 4 | inc Z =^= S(Z) 5 | inc S(np) =^= 6 | let npp = inc np 7 | in S(npp) 8 | 9 | -- fib :: N -> N * N 10 | fib Z =^= {S(Z),S(Z)} 11 | fib S(m) =^= 12 | let {x,y} = fib m 13 | in let z = plus {y,x} 14 | in z 15 | 16 | -- swap :: a * b -> b * a 17 | swap {x,y} =^= {y,x} 18 | 19 | -- scanr :: N * [N] -> N * [N] 20 | scanr {i,[]} =^= {i,[]} 21 | scanr {i, (x:xs)} =^= 22 | let {i', x'} = plus {i,x} 23 | in let {x'',l} = scanr {x', xs} 24 | in {i',(x'':l)} 25 | 26 | -- scanl :: N * [N] -> N * [N] 27 | scanl {i,[]} =^= {i,[]} 28 | scanl {i,[x]} =^= 29 | let {i', x'} = plus {i,x} 30 | in {i', [x']} 31 | scanl {i, (x:z:xs)} =^= 32 | let {i', (y:ys)} = scanl {i,(z:xs)} 33 | in let {y',x'} = plus {y,x} 34 | in {i', (x':y':ys)} 35 | 36 | -- map :: [N] -> [N] 37 | map [] =^= [] 38 | map (x:xs) =^= 39 | let x' = inc x 40 | in let xs' = map xs 41 | in (x':xs') 42 | 43 | -- map :: [N] -> [N] 44 | map2 {f,[]} =^= {f,[]} 45 | map2 {f,(x:xs)} =^= 46 | let x' = f x 47 | in let xs' = map xs 48 | in {f,(x':xs')} 49 | 50 | 51 | -- plus :: N * N -> N * N 52 | plus {x,Z} =^= |{x}| 53 | plus {x,S(u)} =^= 54 | let {xp,up} = plus {x,u} 55 | in {xp, S(up)} 56 | 57 | -- pack :: Eq a => [a] -> [a * N] 58 | pack [] =^= [] 59 | pack (c1 : r) =^= 60 | let s = pack r in 61 | case s of 62 | [] -> ({c1, S(Z)} : []) 63 | (h : t) -> 64 | case h of 65 | {c2, n} -> 66 | case |{c1,c2}| of 67 | {c1p, c2p} -> ({c1p, S(Z)} : ({c2p, n} : t)) 68 | {c} -> ({c, S(n)} : t) 69 | 70 | unpack s =^= rlet s = pack d in d 71 | -------------------------------------------------------------------------------- /core_examples/newSyntax.rfun: -------------------------------------------------------------------------------- 1 | data Nat = Z 2 | | S Nat 3 | 4 | plus :: Nat -> (Nat => Nat) 5 | plus Z x = x 6 | plus S(y) x = 7 | let x' = plus y x 8 | in S(x') 9 | 10 | fib :: Nat => (Nat, Nat) 11 | fib Z = (S(Z),S(Z)) 12 | fib S(m) = 13 | let {x,y} = fib m 14 | y' = plus x y 15 | in {y',x} 16 | 17 | test x = 18 | let p5 = plus 5 19 | in p5 x 20 | 21 | 22 | zip x y = 23 | 24 | 25 | 26 | 27 | -- map applying the function given in fun 28 | map :: (a => b) -> [a] => [b] 29 | map fun [] = [] 30 | map fun (x : xs) = 31 | let x' <= fun x 32 | xs' <= map fun xs 33 | in (x' : xs') 34 | -- map fun (x : xs) = (fun x):(map fun xs) 35 | 36 | scanl :: (a -> b => a) -> a -> [b] => [a] 37 | scanl fun i [] = [] 38 | scanl fun i (x:xs) = 39 | let x' = fun i x 40 | xs' = scanl fun x' xs 41 | in (x' : xs') 42 | 43 | foldl :: (b -> a => a) -> [b] -> a => a 44 | foldl fun [] a = a 45 | foldl fun (x:xs) a = 46 | let a' = fun x a 47 | in foldl fun xs a' 48 | --foldl fun (x:xs) a = foldl fun xs (fun x a) 49 | 50 | foldr :: (b -> a => a) -> [b] -> a => a 51 | foldr fun [] a = a 52 | foldr fun (x:xs) a = 53 | let a' = foldr fun xs a 54 | in fun x a' 55 | 56 | 57 | length :: [a] -> () => Nat 58 | length [] = Z 59 | length (x : xs) = S(length xs) 60 | 61 | reverse :: [a] => [a] 62 | reverse xs =^= 63 | let xs_s = length xs () 64 | ([], ys) = move xs_s (xs, []) 65 | rlet () = length ys xs_s 66 | in ys 67 | 68 | move :: Nat -> ([a], [a]) => ([a], [a]) 69 | move Z ( x , l) = (x, l) 70 | move S(s) ((x:xs), l) = 71 | move s {xs,(x:l)} 72 | 73 | -------------------------------------------------------------------------------- /core_examples/pack.rfun: -------------------------------------------------------------------------------- 1 | pack s =^= 2 | case s of 3 | [] -> [] 4 | (c1 : r) -> 5 | let s = pack r in 6 | case s of 7 | [] -> ({c1, S(Z)} : []) 8 | (h : t) -> 9 | case h of 10 | {c2, n} -> 11 | case |{c1,c2}| of 12 | {c1p, c2p} -> ({c1p, S(Z)} : ({c2p, n} : t)) 13 | {c} -> ({c, S(n)} : t) -------------------------------------------------------------------------------- /core_examples/plus.rfun: -------------------------------------------------------------------------------- 1 | -- Plus using the dup/eq expression (not "Type-safe") 2 | plus { Z , y} =^= |{y}| 3 | plus {S(x), y} =^= 4 | let {xp,yp} = plus {x,y} 5 | in {S(xp), yp} 6 | 7 | -- Plus without dup/eq (no deep matching is required) 8 | plusAlt {Z, Z } =^= {Z, Z} 9 | plusAlt {S(x), Z } =^= 10 | let x' = plusAlt {x, Z} 11 | in {S(x'), Z} 12 | plusAlt {x, S(y)} =^= 13 | let {x', y'} = plusAlt {x, y} 14 | in {S(x'), S(y')} 15 | 16 | -- Plus that also supports negative numbers 17 | plusNeg {x, Z } =^= {x, Z} 18 | plusNeg {x, S(y)} =^= 19 | case plusNeg {x,y} of 20 | { Z , y'} -> { S(Z) , S(y')} 21 | {S(x'), y'} -> {S(S(x')), S(y')} 22 | {P(x'), y'} -> { x' , S(y')} 23 | plusNeg {x, P(y)} =^= 24 | case plusNeg {x,y} of 25 | { Z , y'} -> { P(Z) , P(y')} 26 | {P(x'), y'} -> {P(P(x')), P(y')} 27 | {S(x'), y'} -> { x' , P(y')} 28 | 29 | -------------------------------------------------------------------------------- /core_examples/programs.rfun: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------- 2 | ---- BASIC 3 | --------------------------------------------------------------- 4 | 5 | -- swap :: a * b -> b * a 6 | swap {x,y} =^= {y,x} 7 | 8 | flip {fun, val} =^= 9 | let val' = swap val 10 | upd = fun val' 11 | upd' = swap upd 12 | in {fun, upd'} 13 | 14 | 15 | id x =^= x 16 | 17 | -- It is possible to diverge 18 | rec x =^= 19 | let x' = rec x 20 | in x' 21 | 22 | -- |Implemententation of |.| as a function 23 | -- dupEq v =^= 24 | -- case |v| of 25 | -- v' -> v' 26 | 27 | dupEq v =^= |v| 28 | 29 | dup v =^= |{v}| 30 | 31 | eq v =^= 32 | rlet v = dup v' 33 | in v' 34 | 35 | --------------------------------------------------------------- 36 | ---- ARITHMETIC 37 | --------------------------------------------------------------- 38 | 39 | --data N = Z | S(n) 40 | 41 | -- even :: N -> Either N N 42 | even_ Z =^= Right(Z) 43 | even_ S(Z) =^= Left(S(Z)) 44 | even_ S(S(x)) =^= 45 | let x' = even_ x 46 | in case x' of 47 | Right(x'') -> Right (S(S(x''))) 48 | Left(x'') -> Left (S(S(x''))) 49 | 50 | -- even :: N -> N 51 | -- only defined for even numbers 52 | even Z =^= Z 53 | even S(S(x)) =^= 54 | let x' = even x 55 | in S(S(x')) 56 | 57 | -- odd :: N -> N 58 | -- only defined for odd numbers 59 | odd S(Z) =^= S(Z) 60 | odd S(S(x)) =^= 61 | let x' = odd x 62 | in S(S(x')) 63 | 64 | incT Z =^= S(Z) 65 | incT S(np) =^= 66 | let npp = incT np 67 | in S(npp) 68 | 69 | inc s =^= S(s) 70 | 71 | --plus :: Nat -> Nat <-> Nat 72 | plus { Z , y} =^= |{y}| 73 | plus {S(x), y} =^= 74 | let {xp,yp} = plus {x,y} 75 | in {S(xp), yp} 76 | 77 | plusS { x , y} =^= 78 | let {y', x'} = plus {y,x} 79 | in {x', y'} 80 | 81 | -- Ikke peano safe plusP med Z 82 | plusP {Z, Z} =^= {Z, Z} 83 | plusP {S(x), Z} =^= 84 | let {x',Z} = plusP {x, Z} 85 | in {S(x'),Z} 86 | plusP {x,S(y)} =^= 87 | let {xp,yp} = plusP {x,y} 88 | in {S(xp), S(yp)} 89 | 90 | minus xy =^= 91 | rlet xy = plus xyp 92 | in xyp 93 | 94 | -- fib :: N -> N * N 95 | fib Z =^= {S(Z),S(Z)} 96 | fib S(m) =^= 97 | let {x,y} = fib m 98 | in plus {y,x} 99 | 100 | mult {x, Z } =^= {x, Z} 101 | --mult {x, S(Z) } =^= |{x}| 102 | mult {x, S(y)} =^= 103 | let {xp, yp} = mult {x, y} 104 | {ypp, xpp} = plusP {yp, xp} 105 | in {xpp, ypp} 106 | 107 | mult2 {x, y} =^= 108 | let {y', x'} = mult {y,x} 109 | in {x', y'} 110 | 111 | div {x, S(y)} =^= 112 | rlet {S(y), x} = mult {yp, xp} 113 | in {xp, yp} 114 | 115 | -- fact Z =^= Z 116 | -- fact S(n) =^= 117 | -- let 118 | 119 | --------------------------------------------------------------- 120 | ---- BINARY ARITHMETIC 121 | --------------------------------------------------------------- 122 | 123 | --data BOOL = T | F 124 | --data N = [Bool] 125 | 126 | xor {T, F} =^= {T, T} 127 | xor {T, T} =^= {T, F} 128 | xor {F, F} =^= {F, F} 129 | xor {F, T} =^= {F, T} 130 | 131 | tof {T, T, T} =^= {T, T, F} 132 | tof {T, T, F} =^= {T, T, T} 133 | tof {T, F, T} =^= {T, F, T} 134 | tof {T, F, F} =^= {T, F, F} 135 | tof {F, T, T} =^= {F, T, T} 136 | tof {F, T, F} =^= {F, T, F} 137 | tof {F, F, T} =^= {F, F, T} 138 | tof {F, F, F} =^= {F, F, F} 139 | 140 | maj {T, T, T} =^= {{T, T}, T} 141 | maj {T, T, F} =^= {{T, F}, T} 142 | maj {T, F, T} =^= {{F, T}, T} 143 | maj {T, F, F} =^= {{T, T}, F} 144 | maj {F, T, T} =^= {{F, F}, T} 145 | maj {F, T, F} =^= {{T, F}, F} 146 | maj {F, F, T} =^= {{F, T}, F} 147 | maj {F, F, F} =^= {{F, F}, F} 148 | 149 | sum {a, b ,c} =^= 150 | let {a', c'} = xor {a, c} 151 | {b', c''} = xor {b, c'} 152 | in {a', b', c''} 153 | 154 | bAdd {a, b} =^= 155 | let {a', b', F} = bAddh {a, b, F} 156 | in {a', b'} 157 | 158 | bAddh {[], [], c} =^= {[], [], c} 159 | bAddh {(a:as), (b:bs), c} =^= 160 | let {tmp, c'} = maj {a, b, c} 161 | {as', ss, c''} = bAddh {as, bs, c'} 162 | rlet {tmp, c''} = maj {a', b', c'''} 163 | let {a'', c'''', s} = sum {a', c''', b'} 164 | in {(a'':as'), (s:ss), c''''} 165 | 166 | 167 | --------------------------------------------------------------- 168 | ---- GENERAL ARITHMETIC 169 | --------------------------------------------------------------- 170 | 171 | -- This square root function is very simple and basically iterates 172 | -- over all possible integers. Function will fail if the input 173 | -- is not the square of an integer. 174 | sqrt s =^= 175 | let {i,sq} = sqrt_h {1,1,s} 176 | {sq'} = dupEq {S(i),sq} 177 | in sq' 178 | 179 | sqrt_h {n,m,s} =^= 180 | case |{m,s}| of 181 | {m',s'} -> 182 | let {m'',s''} = less {m',s'} 183 | {n',m'''} = plus {n,m''} 184 | {n'',m4} = plus {S(n'),m'''} 185 | {i,sq} = sqrt_h {n'',m4,s''} 186 | in {S(i),sq} 187 | {s'} -> 188 | let {n',n''} = divide {n,s'} 189 | {n'''} = dupEq {n',n''} 190 | in {Z,n'''} 191 | 192 | square x =^= rlet x = sqrt x' in x' 193 | 194 | compare {Z , Z } =^= EQ(Z) 195 | compare {Z , S(b)} =^= LT(Z,S(b)) 196 | compare {S(a), Z } =^= GT(S(a),Z) 197 | compare {S(a), S(b)} =^= 198 | let c = compare {a,b} 199 | in case c of 200 | EQ(a) -> EQ(S(a)) 201 | LT(a, b) -> LT(S(a), S(b)) 202 | GT(a, b) -> GT(S(a), S(b)) 203 | 204 | less { Z , S(b)} =^= {Z, S(b)} 205 | less {S(a), S(b)} =^= 206 | let {a', b'} = less {a, b} 207 | in {S(a'), S(b')} 208 | 209 | neq { Z , S(b)} =^= {Z, S(b)} 210 | neq {S(a), Z } =^= {S(a), Z} 211 | neq {S(a), S(b)} =^= 212 | let {a', b'} = neq {a, b} 213 | in {S(a'), S(b')} 214 | 215 | eq {a,b} =^= 216 | case |{a,b}| of 217 | {x} -> x 218 | 219 | --------------------------------------------------------------- 220 | ---- LIST TRANSFORMATION 221 | --------------------------------------------------------------- 222 | 223 | -- |Zip 224 | zip {[],[]} =^= [] 225 | zip {(x:xs),(y:ys)} =^= 226 | let zs = zip {xs, ys} 227 | in ({x,y}:zs) 228 | 229 | -- |Unzip 230 | unzip v =^= rlet v = zip v' in v' 231 | 232 | 233 | -- scan1 is basic functions 234 | scanl1 {fun, []} =^= {fun, []} 235 | scanl1 {fun, [x]} =^= {fun, [x]} 236 | scanl1 {fun, (x:y:xs)} =^= 237 | let {x', y'} = fun {x, y} 238 | {fun', (y'':xs')} = scanl1 {fun, (y':xs)} 239 | in {fun', (x':y'':xs')} 240 | 241 | scanr1 {fun, []} =^= {fun, []} 242 | scanr1 {fun, [x]} =^= {fun, [x]} 243 | scanr1 {fun, (x:y:xs)} =^= 244 | let {fun', (y':xs')} = scanr1 {fun, (y:xs)} 245 | {y'', x'} = fun' {y', x} 246 | in {fun', (x':y'':xs')} 247 | 248 | scanr12 {fun, ls} =^= 249 | let ls' = reverse ls 250 | {fun', ls''} = scanl1 {fun, ls'} 251 | ls''' = reverse ls'' 252 | in {fun', ls'''} 253 | 254 | sumInc {x,y} =^= 255 | let {x',y'} = plus {x,y} 256 | in {x',S(y')} 257 | 258 | sumInc2 {x,y} =^= 259 | let {y',x'} = plus {y,x} 260 | in {S(x'),y'} 261 | 262 | -- foldr applying function given in fun 263 | -- this is actually more similar to mapAccumL 264 | mapAccumL {fun,x,[]} =^= {fun,x,[]} 265 | mapAccumL {fun,x,(y:ys)} =^= 266 | let {x',y'} = fun {x,y} 267 | {fun', x'',ys'} = mapAccumL {fun, x',ys} 268 | in {fun', x'', (y':ys')} 269 | 270 | 271 | -- scanr applying function given in fun 272 | scanl {fun, i, []} =^= {fun, i, []} 273 | scanl {fun, i, (x:xs)} =^= 274 | let {i', x'} = fun {i, x} 275 | {fun', x'', l} = scanl {fun, x', xs} 276 | in {fun', i', (x'' : l)} 277 | 278 | -- scanl applying function given in fun 279 | scanr {fun, i, []} =^= {fun, i, []} 280 | scanr {fun, i, [x]} =^= 281 | let {i', x'} = fun {i, x} 282 | in {fun, i', [x']} 283 | scanr {fun, i, (x : z : xs)} =^= 284 | let {fun', i', (y:ys)} = scanr {fun, i, (z : xs)} 285 | {y', x'} = fun' {y, x} 286 | in {fun', i', (x' : y' : ys)} 287 | 288 | 289 | -- foldr applying function given in fun 290 | -- this is actually more similar to mapAccumL 291 | foldl {fun,x,[]} =^= {fun,x,[]} 292 | foldl {fun,x,(y:ys)} =^= 293 | let {y',x'} = fun {y,x} 294 | {fun', x'',ys'} = foldl {fun, x',ys} 295 | in {fun', x'', (y':ys')} 296 | 297 | flip2 {{fun, x}, y} =^= 298 | let {y', x'} = fun {y, x} 299 | in {{fun, y'}, x'} 300 | 301 | foldl2 {flipFun, fun, x, ys} =^= 302 | let {flipFun', {fun',x'}, ys'} = scanl {flipFun, {fun, x}, ys} 303 | in {flipFun', fun', x', ys'} 304 | 305 | foldl1 {fun, (x:xs)} =^= 306 | let {x',x''} = dupEq {x} 307 | {fun', y, xs'} = foldl {fun, x',xs} 308 | in {fun', y,(x'':xs')} 309 | 310 | 311 | -- foldl applying function given in fun 312 | -- this is actually more similar to mapAccumL 313 | foldr {fun,x,[]} =^= {fun,x,[]} 314 | foldr {fun,x,(y:ys)} =^= 315 | let {fun',x',ys'} = foldr {fun,x,ys} 316 | {y',x''} = fun' {y,x'} 317 | in {fun', x'', (y':ys')} 318 | 319 | foldr1 {fun,[x]} =^= 320 | let {x',x''} = dupEq {x} 321 | in {fun,x',[x'']} 322 | foldr1 {fun,(y:ys)} =^= 323 | let {fun',x,ys'} = foldr1 {fun, ys} 324 | {y',x'} = fun' {y,x} 325 | in {fun', x', (y':ys')} 326 | 327 | 328 | -- map applying the function given in fun 329 | map {fun, [] } =^= {fun, []} 330 | map {fun, (x : xs)} =^= 331 | let x' = fun x 332 | {fun', xs'} = map {fun, xs} 333 | in {fun', (x' : xs')} 334 | 335 | -- Simple reverse with last 336 | rev [] =^= [] 337 | rev (x:xs) =^= 338 | let xs' = rev xs 339 | rlet {xs',x} = last xs'' 340 | in xs'' 341 | 342 | -- Reverse of a list 343 | reverse xs =^= 344 | let {xs_s, xs'} = length xs 345 | {[], ys, xs_s'} = move {xs', [], xs_s} 346 | rlet {xs_s', ys} = length ys' 347 | in ys' 348 | 349 | -- This function in only partial 350 | -- helper to reverse 351 | move { x , l, Z } =^= {x, l, Z} 352 | move {(x:xs), l, S(s)} =^= 353 | let {ys, ls, s'} = move {xs,(x:l),s} 354 | in {ys, ls, S(s')} 355 | 356 | -- splitAt is identical to the Haskell version 357 | splitAt { Z , l } =^= {[],l} 358 | splitAt {S(s), (l : ls)} =^= 359 | let {l1, l2} = splitAt {s, ls} 360 | in {(l : l1), l2} 361 | 362 | -- Finds the head and tail 363 | hdtl (x:xs) =^= {x,xs} 364 | 365 | -- Finds the last elements and the rest of the list 366 | last ([x]) =^= {[],x} 367 | last (x:xs) =^= 368 | let {xs',l} = last xs 369 | in {(x:xs'),l} 370 | 371 | 372 | -- If it is called reverse and the N is not equal 373 | -- to the length of the list, I will fail. 374 | length [] =^= {Z,[]} 375 | length (x : xs) =^= 376 | let {l, xs'} = length xs 377 | in {S(l), (x : xs')} 378 | 379 | -- append function 380 | append {[],l} =^= {[], l} 381 | append {(x : xs), l} =^= 382 | let {xs', l'} = append {xs, l} 383 | {x', x''} = dupEq {x} 384 | in {(x' : xs'), (x'' : l')} 385 | 386 | -- The reverse of the append 387 | unAppend x =^= 388 | rlet x = append x' 389 | in x' 390 | 391 | -- Identical to Haskell replicate function 392 | replicate {S(Z),x} =^= [x] 393 | replicate {S(n),x} =^= 394 | let {x',x''} = dupEq {x} 395 | xs = replicate {n,x'} 396 | in (x'':xs) 397 | 398 | -- Similar to Haskell intersperse function 399 | intersperse {x,[]} =^= {x,[]} 400 | intersperse {x,[y]} =^= {x,[y]} 401 | intersperse {x,(l:list)} =^= 402 | let {x',list'} = intersperse {x,list} 403 | {x'',xn} = dupEq {x'} 404 | in {x'',(l:xn:list')} 405 | 406 | -- Identical to Haskell transpose function 407 | transpose [] =^= [] 408 | transpose (x:xs) =^= 409 | let xs' = transpose xs 410 | in addToLists {x,xs'} 411 | 412 | -- Helper function for transpose 413 | -- Adds empty lists this second input is an empty list, e.g. addToLists {[1,2],[]} = [[1],[2]] 414 | addToLists {[],[]} =^= [] 415 | addToLists {(x:xs),[]} =^= 416 | let ys' = addToLists {xs, []} 417 | in (([x]):ys') 418 | addToLists {(x:xs),(y:ys)} =^= 419 | let ys' = addToLists {xs, ys} 420 | in ((x:y):ys') 421 | 422 | -- Identical to Haskell subsequences function 423 | subsequences [] =^= [[]] 424 | subsequences (x:xs) =^= 425 | let xs' = subsequences xs 426 | in duplicateAdd {x,xs'} 427 | 428 | -- Helper function for subsequences 429 | duplicateAdd {x,[y]} =^= 430 | let {y',y''} = dupEq {y} 431 | in [y',(x:y'')] 432 | duplicateAdd {x,(y:ys)} =^= 433 | let {x',x''} = dupEq {x} 434 | ys' = duplicateAdd{x',ys} 435 | {y',y''} = dupEq {y} 436 | in (y':(x'':y''):ys') 437 | 438 | -- Divide a list into n lists of size m 439 | divideOf {S(Z),m,xs} =^= 440 | rlet {m,xs} = length xs' 441 | in [xs'] 442 | divideOf {S(n),m,xs} =^= 443 | let {m',m''} = dupEq {m} 444 | {x,xs'} = splitAt {m', xs} 445 | xs'' = divideOf {n,m'',xs'} 446 | in (x:xs'') 447 | 448 | -- Divide a list into lists of size m 449 | divideSize {m,xs} =^= 450 | let {len,xs'} = length xs 451 | rlet {m,len} = mult {m',n} 452 | in divideOf {n,m',xs'} 453 | 454 | -- Finds all permutations of a list 455 | -- Does not give the same order as the Haskell version. 456 | permutations [] =^= [] 457 | permutations [x] =^= [[x]] 458 | permutations (x:xs) =^= 459 | let ys = permutations xs 460 | ys' = perms {x,ys} 461 | rlet ys' = divideSize {m,(y:ys'')} 462 | {m,y} = length y' 463 | in (y':ys'') 464 | 465 | -- Helper function for permutations 466 | perms {x,[y]} =^= 467 | let z = interleave {x,y} 468 | in [z] 469 | perms {x, (y:ys)} =^= 470 | let {x',x''} = dupEq {x} 471 | zs = perms {x',ys} 472 | z = interleave {x'',y} 473 | in (z:zs) 474 | 475 | -- Adds x to all possible positions in ys 476 | interleave {x,[]} =^= [[x]] 477 | interleave {x,(y:ys)} =^= 478 | let (z:zs) = interleave {x,ys} 479 | {(x':z'),z''} = dupEq {z} 480 | (z'':zs') = consToLists {y,(z':z'':zs)} 481 | in ((x':z''):zs') 482 | 483 | -- Adds x to the front of all lists in y 484 | consToLists {x,[y]} =^= [(x:y)] 485 | consToLists {x, (y:ys)} =^= 486 | let {x',x''} = dupEq {x} 487 | ys' = consToLists {x',ys} 488 | in ((x'':y):ys') 489 | 490 | -- Identical to Haskell group function 491 | -- and not far from the run-length encoding 492 | group [] =^= [] 493 | group (x:xs) =^= 494 | case group xs of 495 | [] -> [[x]] 496 | ((y:ys):tail) -> 497 | case |{x,y}| of 498 | {x'} -> 499 | let {x'',y''} = dupEq {x'} 500 | in ((x'':y'':ys):tail) 501 | {x',y'} -> ([x']:(y':ys):tail) 502 | 503 | -- Equal to the Haskell tails function 504 | tails [] =^= [[]] 505 | tails (x:xs) =^= 506 | let {xs',xs''} = dupEq {xs} 507 | ys = tails xs' 508 | in ((x:xs''):ys) 509 | 510 | -- Equal to the Haskell inits function 511 | inits [] =^= [[]] 512 | inits (x:xs) =^= 513 | let ys = inits xs 514 | ys' = consToLists {x,ys} 515 | in ([]:ys') 516 | 517 | 518 | --------------------------------------------------------------- 519 | ---- APPLICATIONS 520 | --------------------------------------------------------------- 521 | 522 | -- pack :: Eq a => [a] -> [a * N] 523 | pack [] =^= [] 524 | pack (c1 : r) =^= 525 | case pack r of 526 | [] -> [{c1, S(Z)}] 527 | ({c2, n} : t) -> 528 | case |{c1,c2}| of 529 | {c1p, c2p} -> ({c1p, S(Z)} : ({c2p, n} : t)) 530 | {c} -> ({c, S(n)} : t) 531 | 532 | 533 | -------------------------------------------------------------------------------- /core_examples/self.rfun: -------------------------------------------------------------------------------- 1 | -- RUNNING THIS SELF-INTERPRETER 2 | -- Functions to run: 3 | -- * testInc (Incrementation) 4 | -- * testUnInc (Reverse execution of inc, i.e. runs the self interpreter backwards) 5 | -- Inputs are numbers 6 | 7 | ------------------------------------------------------------------------------- 8 | -- ** Standard functions 9 | ------------------------------------------------------------------------------- 10 | 11 | -- |Implemententation of |.| as a function 12 | dupEq v =^= |v| 13 | 14 | -- |Zip 15 | zip {[],[]} =^= [] 16 | zip {(x:xs),(y:ys)} =^= 17 | let zs = zip {xs, ys} 18 | in ({x,y}:zs) 19 | 20 | -- |Unzip 21 | unzip v =^= rlet v = zip v' in v' 22 | 23 | -- |Addition 24 | plus {Z,y} =^= {Z,y} 25 | plus {S(x), y} =^= 26 | let {x',y'} = plus {x,y} 27 | in {S(x'), S(y')} 28 | 29 | -- |scanr specialized to plus 30 | scanrPlus {i, []} =^= {i, []} 31 | scanrPlus {i, (x:xs)} =^= 32 | let {i', x'} = plus {i, x} 33 | {x'', l} = scanrPlus {x', xs} 34 | in {i', (x'' : l)} 35 | 36 | ------------------------------------------------------------------------------- 37 | -- ** Substitutions and functions on these 38 | ------------------------------------------------------------------------------- 39 | -- |A substitution is a list of integers to values 40 | -- |The list is ordered and implemented such that the difference (and not the 41 | -- | absolute value) is saved. 42 | -- | E.g., in [{1,A}, {1,B}] we have that lookup {1, ..} is A and lookup {2,..} is B 43 | 44 | -- Perhaps call them get/put 45 | -- lookup :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 46 | lookup {Z, ({Z,v}:sub)} =^= {{Z,v},sub} 47 | lookup {S(a), ({Z,v}:sub)} =^= 48 | let {{a',r}, sub'} = lookup {S(a), sub} 49 | in {{a',r}, ({Z,v}:sub')} 50 | lookup {S(a), ({S(b),v}:sub)} =^= 51 | let {{a',r}, l} = lookup {a, ({b,v}:sub)} in 52 | case l of 53 | [] -> {{S(a'),r}, []} 54 | ({b',v}:sub') -> {{S(a'),r}, ({S(b'),v}:sub')} 55 | 56 | -- insert :: {{N,a},[{N,a}]} -> {N,[{N,a}]} 57 | insert v =^= rlet v = lookup v' in v' 58 | 59 | -- |This is actually scanr specialised to insert 60 | -- disUnion :: {[{N,a}],[{N,a}]} -> {[N],[{N,a}]} 61 | disUnion {sub1, sub2} =^= 62 | let {x,v} = unzip sub1 63 | {0, xInc} = scanrPlus {0,x} 64 | sub1Inc = zip {xInc,v} 65 | {listInc, sub} = disUnionh {sub1Inc, sub2} 66 | rlet {0 , listInc} = scanrPlus {0, list} 67 | in {list, sub} 68 | 69 | -- | Basically a scanr specialised to insert 70 | disUnionh {[],sub} =^= {[], sub} 71 | disUnionh {(x:xs), sub} =^= 72 | let {xs', sub'} = disUnionh {xs, sub} 73 | {x' , sub''} = insert {x, sub'} 74 | in {(x' : xs'), sub''} 75 | 76 | -- divide :: {[N],[{N,a}]} -> {[{N,a}],[{N,a}]} 77 | divide v =^= rlet v = disUnion v' in v' 78 | 79 | -- |Similar to lookup, but copies and inserts the found value again 80 | -- loopupFun :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 81 | lookupFun {ident, funEnv} =^= 82 | let {{ident', v}, funEnv'} = lookup {ident, funEnv} 83 | {v',v''} = dupEq {v} 84 | {ident'',funEnv''} = insert {{ident', v'}, funEnv'} 85 | in {ident'', v'', funEnv''} 86 | 87 | ------------------------------------------------------------------------------- 88 | -- ** Finding variables 89 | ------------------------------------------------------------------------------- 90 | 91 | -- |This function is similar to lookup, but without a value 92 | remove {Z, (Z:sub)} =^= {Z,sub} 93 | remove {S(a), (Z:sub)} =^= 94 | let {a', sub'} = remove {S(a), sub} 95 | in {a', (Z:sub')} 96 | remove {S(a), (S(b):sub)} =^= 97 | let {a', l} = remove {a, (b:sub)} in 98 | case l of 99 | [] -> {S(a'), []} 100 | (b':sub') -> {S(a'), (S(b'):sub')} 101 | 102 | add v =^= rlet v = remove v' in v' 103 | 104 | -- |Find the variables in a give left-expression 105 | -- findvars :: {LExpr, [N]} -> {LExpr, [N]} 106 | findvars {Var(x),list} =^= 107 | let {x',list'} = add {x,list} 108 | in {Var(x'), list'} 109 | findvars {DupEq(l), list} =^= 110 | let {l',list'} = findvars {l,list} 111 | in {DupEq(l'), list'} 112 | -- The following to would be better implemented with a map function 113 | findvars {Constr(c,[]),list} =^= {Constr(c,[]),list} 114 | findvars {Constr(c,(v:vars)),list} =^= 115 | let {v', list'} = findvars {v,list} 116 | {Constr(c',vars'), list''} = findvars {Constr(c,vars), list'} 117 | in {Constr(c',(v':vars')), list''} 118 | 119 | ------------------------------------------------------------------------------- 120 | -- ** The interpreter 121 | ------------------------------------------------------------------------------- 122 | 123 | -- evalDupEq :: Value -> Value 124 | evalDupEq ConstrV(Tuple,[x,y]) =^= 125 | case |{x,y}| of 126 | {x'} -> ConstrV(Tuple,[x']) 127 | {x',y'} -> ConstrV(Tuple,[x',y']) 128 | evalDupEq ConstrV(Tuple,[x]) =^= 129 | let {x', x''} = dupEq {x} 130 | in ConstrV(Tuple,[x',x'']) 131 | 132 | -- |evalRMatch have to be lifted to the "Either monad", as 133 | -- | it is used to find minimum match. LExpr are always unchanged. 134 | -- evalRMatch :: {LExpr, Value} -> Either({LExpr,Value},{LExpr,Subst}) 135 | evalRMatch {Var(x),value} =^= 136 | let {x',sub'} = insert {{x,value},[]} 137 | in Right(Var(x'),sub') 138 | evalRMatch {Constr(c,[]),ConstrV(cV,[])} =^= 139 | case |{c,cV}| of 140 | {c'} -> Right(Constr(c',[]), []) 141 | {c',cV'} -> Left(Constr(c',[]),ConstrV(cV',[])) 142 | evalRMatch {Constr(c,[]),ConstrV(cV,(v:varsV))} =^= 143 | Left(Constr(c,[]),ConstrV(cV,(v:varsV))) 144 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,[])} =^= 145 | Left(Constr(c,(v:vars)),ConstrV(cV,[])) 146 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,(vV:varsV))} =^= 147 | let r1 = evalRMatch {v,vV} 148 | r2 = evalRMatch {Constr(c,vars),ConstrV(cV,varsV)} 149 | in case {r1,r2} of 150 | {Right(v', sub'), Right(Constr(c',vars'), sub'')} -> 151 | let {l,sub} = disUnion {sub',sub''} 152 | rlet {v',l} = findvars {v'',[]} 153 | in Right(Constr(c',(v'':vars')), sub) 154 | {r1',r2'} -> 155 | rlet r1' = evalRMatch {v', vV'} 156 | r2' = evalRMatch {Constr(c',vars'),ConstrV(cV',varsV')} 157 | in Left(Constr(c',(v':vars')), ConstrV(cV',(vV':varsV'))) 158 | evalRMatch {DupEq(l), value} =^= 159 | let value' = evalDupEq value 160 | in case evalRMatch {l, value'} of 161 | Right(l',sub') -> Right(DupEq(l'), sub') 162 | Left(l',value'') -> 163 | rlet value'' = evalDupEq value''' 164 | in Left(DupEq(l'),value''') 165 | 166 | -- |Helper function that evaluates a function. 167 | -- |All inputs are unchanged expect the Subst -> Value 168 | -- evalFun :: {FunEnv, Ident, LExpr, Subst} -> {FunEnv, Ident, LExpr, Value} 169 | evalFun {funEnv, ident, lexpr, sub} =^= 170 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 171 | {LeftE(lexpr'), funEnv'', v'} = evalExp {LeftE(lexpr), funEnv', sub} 172 | Right(funL', sub_f) = evalRMatch {funL, v'} 173 | {funE', funEnv''', value} = evalExp {funE, funEnv'', sub_f} 174 | rlet {ident', {funL', funE'}, funEnv'''} = lookupFun {ident'', funEnv''''} 175 | in {funEnv'''', ident'', lexpr', value} 176 | 177 | -- |Evaluation of expressions. 178 | -- |All inputs are unchanged expect the Subst -> Value 179 | -- evalExp :: {Expr, FunEnv, Subst} -> {Expr, FunEnv, Value} 180 | evalExp {LeftE(l), funEnv, sub} =^= 181 | rlet Right(l, sub) = evalRMatch {l', value} 182 | in {LeftE(l'), funEnv, value} 183 | evalExp {LetIn(lout, ident, lin, expr), funEnv, sub} =^= 184 | let {lin', v_lin} = findvars {lin,[]} 185 | {sub_in,sub_e} = divide {v_lin, sub} 186 | {funEnv', ident', lin'', vout} = evalFun {funEnv, ident, lin', sub_in} 187 | Right(lout', sub_out) = evalRMatch {lout, vout} 188 | {v_lout, sub_ef} = disUnion {sub_out, sub_e} 189 | rlet {lout', v_lout} = findvars {lout'',[]} 190 | let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 191 | in {LetIn(lout'', ident', lin'', expr'), funEnv'', v} 192 | evalExp {RLetIn(lin, ident, lout, expr), funEnv, sub} =^= 193 | rlet {LetIn(lin, ident, lout, expr), funEnv, sub} = evalExp {LetIn(lin', ident', lout', expr'), funEnv', value} 194 | in {RLetIn(lin', ident', lout', expr'), funEnv', value} 195 | -- Implementation of evalExp for the RLet-In case not using the reverse call to Let-In 196 | --let {lin', v_lin} = findvars {lin,[]} 197 | -- {sub_in,sub_e} = divide {v_lin, sub} 198 | --rlet Right(lin', sub_in) = evalRMatch {lin'', vin} 199 | -- {funEnv, ident, lout, vin} = evalFun {funEnv', ident', lout', sub_out} 200 | --let {v_lout, sub_ef} = disUnion {sub_out, sub_e} 201 | --rlet {lout', v_lout} = findvars {lout'',[]} 202 | --let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 203 | --in {RLetIn(lin'', ident', lout'', expr'), funEnv'', v} 204 | evalExp {CaseOf(lExpr, cases), funEnv, sub} =^= 205 | let {lExpr', v_lExpr} = findvars {lExpr,[]} 206 | {sub_l, sub_t} = divide {v_lExpr, sub} 207 | {LeftE(lExpr''), funEnv', vp} = evalExp {LeftE(lExpr'), funEnv, sub_l} 208 | {i, {cLExpr,cExpr}, cases', sub_j} = checkCases {cases, vp} 209 | {v_sub_j,sub_jt} = disUnion {sub_j, sub_t} 210 | rlet {cLExpr, v_sub_j} = findvars {cLExpr',[]} 211 | let {cExpr', funEnv'', value} = evalExp {cExpr, funEnv', sub_jt} 212 | rlet {i,{cLExpr',cExpr'}, cases', value} = checkLeaves {cases'', value'} 213 | in {CaseOf(lExpr'', cases''), funEnv'', value'} 214 | 215 | -- | Finds the case (and index) that matches a value and evaluates this to a substitution 216 | -- checkCases :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Subst} 217 | checkCases {({lExpr,expr}:cases), value} =^= 218 | case evalRMatch {lExpr, value} of 219 | Right(lExpr', sub) -> 220 | let {le1,le2} = dupEq {{lExpr',expr}} 221 | in {Z, le1, (le2:cases), sub} 222 | Left(lExpr', value') -> 223 | let {n, le, cases', sub} = checkCases{cases, value'} 224 | in {S(n), le, ({lExpr',expr}:cases'), sub} 225 | 226 | -- | Similar to checkCases, but for leaves of a case instead of case-matches. 227 | -- checkLeaces :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Value} 228 | checkLeaves{({lExpr,expr}:cases), value} =^= 229 | case checkLeavesOf {expr, value} of 230 | {Right(expr'), value'} -> 231 | let {le1,le2} = dupEq {{lExpr,expr'}} 232 | in {Z, le1, (le2:cases), value'} 233 | {Left(expr'), value'} -> 234 | let {n, le, cases', value''} = checkLeaves {cases, value'} 235 | in {S(n), le, ({lExpr,expr'}:cases'), value''} 236 | 237 | -- | Checks if any leaves of an expression matches a given value. 238 | -- checkLeacesOf :: {Expr, Value} -> {Either(Expr, Expr), Value} 239 | checkLeavesOf {LeftE(lExpr), value} =^= 240 | case evalRMatch {lExpr, value} of 241 | Right(lExpr', sub) -> 242 | rlet Right(lExpr', sub) = evalRMatch {lExpr'', value'} 243 | in {Right(LeftE(lExpr'')), value'} 244 | Left(lExpr', value') -> {Left(LeftE(lExpr')), value'} 245 | checkLeavesOf {LetIn(lout, ident, lin, expr), value} =^= 246 | case checkLeavesOf {expr, value} of 247 | {Right(expr'), value'} -> {Right(LetIn(lout, ident, lin, expr')), value'} 248 | {Left(expr'), value'} -> {Left(LetIn(lout, ident, lin, expr')) , value'} 249 | checkLeavesOf {RLetIn(lout, ident, lin, expr), value} =^= 250 | case checkLeavesOf {expr, value} of 251 | {Right(expr'), value'} -> {Right(RLetIn(lout, ident, lin, expr')), value'} 252 | {Left(expr') , value'} -> {Left(RLetIn(lout, ident, lin, expr')) , value'} 253 | checkLeavesOf {CaseOf(lExpr, []), value} =^= 254 | {Left(CaseOf(lExpr, [])), value} 255 | checkLeavesOf {CaseOf(lExpr, ({clExpr,cexpr}:cases)), value} =^= 256 | let {r1, value'} = checkLeavesOf {cexpr, value} 257 | {r2, value''} = checkLeavesOf {CaseOf(lExpr, cases), value'} 258 | in case {r1, r2} of 259 | {Left(cexpr'), Left(CaseOf(lExpr', cases'))} -> 260 | {Left(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''} 261 | {r1',r2'} -> 262 | rlet {r2', value''} = checkLeavesOf {CaseOf(lExpr', cases'), value'''} 263 | {r1', value'''} = checkLeavesOf {cexpr', value''''} 264 | in {Right(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''''} 265 | 266 | -- | The main evaluation function. 267 | -- | Evaluates a given function name in a function environment with a given value 268 | -- | to some output value. function name and environment are unchanged. 269 | -- eval :: {Ident, FunEnv, Value} -> {FunEnv, Ident, Value} 270 | eval {ident, funEnv, value_i} =^= 271 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 272 | Right(funL', sub_f) = evalRMatch {funL, value_i} 273 | {funE', funEnv'', value_o} = evalExp {funE, funEnv', sub_f} 274 | rlet {ident', {funL', funE'}, funEnv''} = lookupFun {ident'', funEnv'''} 275 | in {funEnv''', ident'', value_o} 276 | 277 | testInc input =^= 278 | let {ident, funEnv} = inc 0 279 | value = fromValue input 280 | {funEnv', ident', value'} = eval {ident, funEnv, value} 281 | rlet {ident', funEnv'} = inc 0 282 | value' = fromValue output 283 | in output 284 | 285 | testUncInc input =^= 286 | let {ident, funEnv} = inc 0 287 | value = fromValue input 288 | rlet {funEnv, ident, value} = eval {ident', funEnv', value'} 289 | rlet {ident', funEnv'} = inc 0 290 | value' = fromValue output 291 | in output 292 | 293 | 294 | inc x =^= {x,[{0,{Var(1), 295 | CaseOf(Var(1), [ 296 | {Constr(Z,[]), LeftE(Constr(S, [Constr(Z,[])]))} 297 | , {Constr(S,[Var(2)]), LetIn(Var(3), 0, Var(2), LeftE(Constr(S, [Var(3)])))} 298 | ])}}]} 299 | 300 | 301 | fromValue Z =^= ConstrV(Z,[]) 302 | fromValue S(n) =^= 303 | let v = fromValue n 304 | in ConstrV(S, [v]) 305 | fromValue {x,y} =^= 306 | let x' = fromValue x 307 | y' = fromValue y 308 | in ConstrV(Tuple, [x',y']) 309 | fromValue {x} =^= 310 | let x' = fromValue x 311 | in ConstrV(Tuple, [x']) 312 | fromValue (x:xs) =^= 313 | let x' = fromValue x 314 | xs' = fromValue xs 315 | in ConstrV(Cons, [x',xs']) 316 | fromValue [] =^= ConstrV(Nil, []) 317 | -------------------------------------------------------------------------------- /core_examples/selfInterp.rfun: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------- 2 | -- ** Standard functions 3 | ------------------------------------------------------------------------------- 4 | 5 | -- |Implemententation of |.| as a function 6 | dupEq v =^= 7 | case |v| of 8 | v' -> v' 9 | 10 | -- |Zip 11 | zip {[],[]} =^= [] 12 | zip {(x:xs),(y:ys)} =^= 13 | let zs = zip {xs, ys} 14 | in ({x,y}:zs) 15 | 16 | -- |Unzip 17 | unzip v =^= rlet v = zip v' in v' 18 | 19 | -- |Addition 20 | --plus {x, Z } =^= |{x}| 21 | --plus {x,S(u)} =^= 22 | -- let {xp,up} = plus {x,u} 23 | -- in {xp, S(up)} 24 | 25 | plus {Z,y} =^= {Z,y} 26 | plus {S(x), y} =^= 27 | let {x',y'} = plus {x,y} 28 | in {S(x'), S(y')} 29 | 30 | 31 | -- |scanr specialized to plus 32 | scanrPlus {i, []} =^= {i, []} 33 | scanrPlus {i, (x:xs)} =^= 34 | let {i', x'} = plus {i, x} 35 | {x'', l} = scanrPlus {x', xs} 36 | in {i', (x'' : l)} 37 | 38 | ------------------------------------------------------------------------------- 39 | -- ** Substitutions and functions on these 40 | ------------------------------------------------------------------------------- 41 | -- |A substitution is a list of integers to values 42 | -- |The list is ordered and implemented such that the difference (and not the 43 | -- |absolute value) is saved. 44 | --| E.g., in [{1,A}, {1,B}] we have that lookup {1, ..} is A and lookup {2,..} is B 45 | 46 | 47 | -- Perhaps call then get/put 48 | -- lookup :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 49 | lookup {Z, ({Z,v}:sub)} =^= {{Z,v},sub} 50 | lookup {S(a), ({Z,v}:sub)} =^= 51 | let {{a',r}, sub'} = lookup {S(a), sub} 52 | in {{a',r}, ({Z,v}:sub')} 53 | lookup {S(a), ({S(b),v}:sub)} =^= 54 | let {{a',r}, l} = lookup {a, ({b,v}:sub)} in 55 | case l of 56 | [] -> {{S(a'),r}, []} 57 | ({b',v}:sub') -> {{S(a'),r}, ({S(b'),v}:sub')} 58 | 59 | -- insert :: {{N,a},[{N,a}]} -> {N,[{N,a}]} 60 | insert v =^= rlet v = lookup v' in v' 61 | 62 | -- |This is actually scanr specialised to insert 63 | -- disUnion :: {[{N,a}],[{N,a}]} -> {[N],[{N,a}]} 64 | disUnion {sub1, sub2} =^= 65 | let {x,v} = unzip sub1 66 | {0, xInc} = scanrPlus {0,x} 67 | sub1Inc = zip {xInc,v} 68 | {listInc, sub} = disUnionh {sub1Inc, sub2} 69 | rlet {0 , listInc} = scanrPlus {0, list} 70 | in {list, sub} 71 | 72 | -- | Basically a scanr specialised to insert 73 | disUnionh {[],sub} =^= {[], sub} 74 | disUnionh {(x:xs), sub} =^= 75 | let {xs', sub'} = disUnionh {xs, sub} 76 | {x' , sub''} = insert {x, sub'} 77 | in {(x' : xs'), sub''} 78 | 79 | -- divide :: {[N],[{N,a}]} -> {[{N,a}],[{N,a}]} 80 | divide v =^= rlet v = disUnion v' in v' 81 | 82 | -- |Similar to lookup, but copies and inserts the found value again 83 | -- loopupFun :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 84 | lookupFun {ident, funEnv} =^= 85 | let {{ident', v}, funEnv'} = lookup {ident, funEnv} 86 | {v',v''} = dupEq {v} 87 | {ident'',funEnv''} = insert {{ident', v'}, funEnv'} 88 | in {ident'', v'', funEnv''} 89 | 90 | ------------------------------------------------------------------------------- 91 | -- ** Finding variables 92 | ------------------------------------------------------------------------------- 93 | 94 | -- |This function is similar to lookup, but without a value 95 | remove {Z, (Z:sub)} =^= {Z,sub} 96 | remove {S(a), (Z:sub)} =^= 97 | let {a', sub'} = remove {S(a), sub} 98 | in {a', (Z:sub')} 99 | remove {S(a), (S(b):sub)} =^= 100 | let {a', l} = remove {a, (b:sub)} in 101 | case l of 102 | [] -> {S(a'), []} 103 | (b':sub') -> {S(a'), (S(b'):sub')} 104 | 105 | add v =^= rlet v = remove v' in v' 106 | 107 | -- |Find the variables in a give left-expression 108 | -- findvars :: {LExpr, [N]} -> {LExpr, [N]} 109 | findvars {Var(x),list} =^= 110 | let {x',list'} = add {x,list} 111 | in {Var(x'), list'} 112 | findvars {DupEq(l), list} =^= 113 | let {l',list'} = findvars {l,list} 114 | in {DupEq(l'), list'} 115 | -- The following to would be better implemented with a map function 116 | findvars {Constr(c,[]),list} =^= {Constr(c,[]),list} 117 | findvars {Constr(c,(v:vars)),list} =^= 118 | let {v', list'} = findvars {v,list} 119 | {Constr(c',vars'), list''} = findvars {Constr(c,vars), list'} 120 | in {Constr(c',(v':vars')), list''} 121 | 122 | ------------------------------------------------------------------------------- 123 | -- ** The interpreter 124 | ------------------------------------------------------------------------------- 125 | 126 | -- evalDupEq :: Value -> Value 127 | evalDupEq ConstrV(Tuple,[x,y]) =^= 128 | case |{x,y}| of 129 | {x'} -> ConstrV(Tuple,[x']) 130 | {x',y'} -> ConstrV(Tuple,[x',y']) 131 | evalDupEq ConstrV(Tuple,[x]) =^= 132 | let {x', x''} = dupEq {x} 133 | in ConstrV(Tuple,[x',x'']) 134 | 135 | -- |evalRMatch have to be lifted to the "Either monad", as 136 | -- | it is used to find minimum match. LExpr are always unchanged. 137 | -- evalRMatch :: {LExpr, Value} -> Either({LExpr,Value},{LExpr,Subst}) 138 | evalRMatch {Var(x),value} =^= 139 | let {x',sub'} = insert {{x,value},[]} 140 | in Right(Var(x'),sub') 141 | evalRMatch {Constr(c,[]),ConstrV(cV,[])} =^= 142 | case |{c,cV}| of 143 | {c'} -> Right(Constr(c',[]), []) 144 | {c',cV'} -> Left(Constr(c',[]),ConstrV(cV',[])) 145 | evalRMatch {Constr(c,[]),ConstrV(cV,(v:varsV))} =^= 146 | Left(Constr(c,[]),ConstrV(cV,(v:varsV))) 147 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,[])} =^= 148 | Left(Constr(c,(v:vars)),ConstrV(cV,[])) 149 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,(vV:varsV))} =^= 150 | let r1 = evalRMatch {v,vV} 151 | r2 = evalRMatch {Constr(c,vars),ConstrV(cV,varsV)} 152 | in case {r1,r2} of 153 | {Right(v', sub'), Right(Constr(c',vars'), sub'')} -> 154 | let {l,sub} = disUnion {sub',sub''} 155 | rlet {v',l} = findvars {v'',[]} 156 | in Right(Constr(c',(v'':vars')), sub) 157 | {r1',r2'} -> 158 | rlet r1' = evalRMatch {v', vV'} 159 | r2' = evalRMatch {Constr(c',vars'),ConstrV(cV',varsV')} 160 | in Left(Constr(c',(v':vars')), ConstrV(cV',(vV':varsV'))) 161 | evalRMatch {DupEq(l), value} =^= 162 | let value' = evalDupEq value 163 | in case evalRMatch {l, value'} of 164 | Right(l',sub') -> Right(DupEq(l'), sub') 165 | Left(l',value'') -> 166 | rlet value'' = evalDupEq value''' 167 | in Left(DupEq(l'),value''') 168 | 169 | -- |Helper function that evaluates a function. 170 | -- |All inputs are unchanged expect the Subst -> Value 171 | -- evalFun :: {FunEnv, Ident, LExpr, Subst} -> {FunEnv, Ident, LExpr, Value} 172 | evalFun {funEnv, ident, lexpr, sub} =^= 173 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 174 | {LeftE(lexpr'), funEnv'', v'} = evalExp {LeftE(lexpr), funEnv', sub} 175 | Right(funL', sub_f) = evalRMatch {funL, v'} 176 | {funE', funEnv''', value} = evalExp {funE, funEnv'', sub_f} 177 | rlet {ident', {funL', funE'}, funEnv'''} = lookupFun {ident'', funEnv''''} 178 | in {funEnv'''', ident'', lexpr', value} 179 | 180 | -- |Evaluation of expressions. 181 | -- |All inputs are unchanged expect the Subst -> Value 182 | -- evalExp :: {Expr, FunEnv, Subst} -> {Expr, FunEnv, Value} 183 | evalExp {LeftE(l), funEnv, sub} =^= 184 | rlet Right(l, sub) = evalRMatch {l', value} 185 | in {LeftE(l'), funEnv, value} 186 | evalExp {LetIn(lout, ident, lin, expr), funEnv, sub} =^= 187 | let {lin', v_lin} = findvars {lin,[]} 188 | {sub_in,sub_e} = divide {v_lin, sub} 189 | {funEnv', ident', lin'', vout} = evalFun {funEnv, ident, lin', sub_in} 190 | Right(lout', sub_out) = evalRMatch {lout, vout} 191 | {v_lout, sub_ef} = disUnion {sub_out, sub_e} 192 | rlet {lout', v_lout} = findvars {lout'',[]} 193 | let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 194 | in {LetIn(lout'', ident', lin'', expr'), funEnv'', v} 195 | evalExp {RLetIn(lin, ident, lout, expr), funEnv, sub} =^= 196 | --rlet {LetIn(lin, ident, lout, expr), funEnv, sub} = evalExp {LetIn(lin', ident', lout', expr'), funEnv', value} 197 | let {lin', v_lin} = findvars {lin,[]} 198 | {sub_in,sub_e} = divide {v_lin, sub} 199 | rlet Right(lin', sub_in) = evalRMatch {lin'', vin} 200 | {funEnv, ident, lout, vin} = evalFun {funEnv', ident', lout', sub_out} 201 | let {v_lout, sub_ef} = disUnion {sub_out, sub_e} 202 | rlet {lout', v_lout} = findvars {lout'',[]} 203 | let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 204 | in {RLetIn(lin'', ident', lout'', expr'), funEnv'', v} 205 | --in {RLetIn(lin', ident', lout', expr'), funEnv', value} 206 | evalExp {CaseOf(lExpr, cases), funEnv, sub} =^= 207 | let {lExpr', v_lExpr} = findvars {lExpr,[]} 208 | {sub_l, sub_t} = divide {v_lExpr, sub} 209 | {LeftE(lExpr''), funEnv', vp} = evalExp {LeftE(lExpr'), funEnv, sub_l} 210 | {i, {cLExpr,cExpr}, cases', sub_j} = checkCases {cases, vp} 211 | {v_sub_j,sub_jt} = disUnion {sub_j, sub_t} 212 | rlet {cLExpr, v_sub_j} = findvars {cLExpr',[]} 213 | let {cExpr', funEnv'', value} = evalExp {cExpr, funEnv', sub_jt} 214 | rlet {i,{cLExpr',cExpr'}, cases', value} = checkLeaves {cases'', value'} 215 | in {CaseOf(lExpr'', cases''), funEnv'', value'} 216 | 217 | -- | Finds the case (and index) that matches a value and evaluates this to a substitution 218 | -- checkCases :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Subst} 219 | checkCases {({lExpr,expr}:cases), value} =^= 220 | case evalRMatch {lExpr, value} of 221 | Right(lExpr', sub) -> 222 | let {le1,le2} = dupEq {{lExpr',expr}} 223 | in {Z, le1, (le2:cases), sub} 224 | Left(lExpr', value') -> 225 | let {n, le, cases', sub} = checkCases{cases, value'} 226 | in {S(n), le, ({lExpr',expr}:cases'), sub} 227 | 228 | -- | Similar to checkCases, but for leaves of a case instead of case-matches. 229 | -- checkLeaces :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Value} 230 | checkLeaves{({lExpr,expr}:cases), value} =^= 231 | case checkLeavesOf {expr, value} of 232 | {Right(expr'), value'} -> 233 | let {le1,le2} = dupEq {{lExpr,expr'}} 234 | in {Z, le1, (le2:cases), value'} 235 | {Left(expr'), value'} -> 236 | let {n, le, cases', value''} = checkLeaves {cases, value'} 237 | in {S(n), le, ({lExpr,expr'}:cases'), value''} 238 | 239 | -- | Checks if any leaves of an expression matches a given value. 240 | -- checkLeacesOf :: {Expr, Value} -> {Either(Expr, Expr), Value} 241 | checkLeavesOf {LeftE(lExpr), value} =^= 242 | case evalRMatch {lExpr, value} of 243 | Right(lExpr', sub) -> 244 | rlet Right(lExpr', sub) = evalRMatch {lExpr'', value'} 245 | in {Right(LeftE(lExpr'')), value'} 246 | Left(lExpr', value') -> {Left(LeftE(lExpr')), value'} 247 | checkLeavesOf {LetIn(lout, ident, lin, expr), value} =^= 248 | case checkLeavesOf {expr, value} of 249 | {Right(expr'), value'} -> {Right(LetIn(lout, ident, lin, expr')), value'} 250 | {Left(expr'), value'} -> {Left(LetIn(lout, ident, lin, expr')) , value'} 251 | checkLeavesOf {RLetIn(lout, ident, lin, expr), value} =^= 252 | case checkLeavesOf {expr, value} of 253 | {Right(expr'), value'} -> {Right(RLetIn(lout, ident, lin, expr')), value'} 254 | {Left(expr') , value'} -> {Left(RLetIn(lout, ident, lin, expr')) , value'} 255 | checkLeavesOf {CaseOf(lExpr, []), value} =^= 256 | {Left(CaseOf(lExpr, [])), value} 257 | checkLeavesOf {CaseOf(lExpr, ({clExpr,cexpr}:cases)), value} =^= 258 | let {r1, value'} = checkLeavesOf {cexpr, value} 259 | {r2, value''} = checkLeavesOf {CaseOf(lExpr, cases), value'} 260 | in case {r1, r2} of 261 | {Left(cexpr'), Left(CaseOf(lExpr', cases'))} -> 262 | {Left(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''} 263 | {r1',r2'} -> 264 | rlet {r2', value''} = checkLeavesOf {CaseOf(lExpr', cases'), value'''} 265 | {r1', value'''} = checkLeavesOf {cexpr', value''''} 266 | in {Right(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''''} 267 | 268 | -- | The main evaluation function. 269 | -- | Evaluates a given function name in a function environment with a given value 270 | -- | to some output value. function name and environment are unchanged. 271 | -- eval :: {Ident, FunEnv, Value} -> {FunEnv, Ident, Value} 272 | eval {funEnv, ident, value_i} =^= 273 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 274 | Right(funL', sub_f) = evalRMatch {funL, value_i} 275 | {funE', funEnv'', value_o} = evalExp {funE, funEnv', sub_f} 276 | rlet {ident', {funL', funE'}, funEnv''} = lookupFun {ident'', funEnv'''} 277 | in {funEnv''', ident'', value_o} 278 | 279 | 280 | 281 | 282 | ------------------------------------------------------------------------------- 283 | -- ** Testing 284 | ------------------------------------------------------------------------------- 285 | 286 | --1 as ConstrV(S, [ConstrV(Z,[])]) 287 | testInc input =^= 288 | let {ident, funEnv} = inc 1 289 | value = fromValue input 290 | -- {funEnv', ident', value'} = eval {ident, funEnv, value} 291 | rlet {funEnv, ident, value} = eval {funEnv', ident', value'} 292 | rlet {ident', funEnv'} = inc 1 293 | value' = fromValue output 294 | in output 295 | 296 | --inc Z =^= S(Z) 297 | --inc S(np) =^= 298 | -- let npp = inc np 299 | -- in S(npp) 300 | 301 | inc2 x =^= {x,[{1,{Var(2), 302 | CaseOf(Var(2), [ 303 | {Constr(Z,[]), LeftE(Constr(S, [Constr(Z,[])]))} 304 | , {Constr(S,[Var(3)]), LetIn(Var(4), 1, Var(3), LeftE(Constr(S, [Var(4)])))} 305 | ])}}]} 306 | 307 | inc x =^= {x,[{1,{Var(2),CaseOf(Var(2),[{Constr(Z,[]),LeftE(Constr(S,[Constr(Z,[])]))},{Constr(S,[Var(3)]),LetIn(Var(4),1,Var(3),LeftE(Constr(S,[Var(4)])))}])}}]} 308 | 309 | testPlus input =^= 310 | let {ident, funEnv} = plus 11 311 | value = fromValue input 312 | {funEnv', ident', value'} = eval {funEnv, ident, value} 313 | rlet {ident', funEnv'} = plus 11 314 | value' = fromValue output 315 | in output 316 | 317 | testMinus input =^= 318 | let {ident, funEnv} = plus 12 319 | value = fromValue input 320 | {funEnv', ident', value'} = eval {funEnv, ident, value} 321 | rlet {ident', funEnv'} = plus 12 322 | value' = fromValue output 323 | in output 324 | 325 | --plus {x, Z } =^= |{x}| 326 | --plus {x,S(u)} =^= 327 | -- let {xp,up} = plus {x,u} 328 | -- in {xp, S(up)} 329 | 330 | plus x =^= {x,[{11,{ Constr(Tuple,[Var(10),Var(4)]), 331 | CaseOf(Var(4), [ 332 | {Constr(Z,[]), LeftE(DupEq(Constr(Tuple,[Var(10)])))} 333 | , {Constr(S,[Var(12)]), 334 | -- LeftE(Constr(Tuple,[Var(1),Var(3)])) 335 | LetIn(Constr(Tuple,[Var(4), Var(5)]), 11, Constr(Tuple,[Var(10),Var(12)]), 336 | LeftE(Constr(Tuple,[Var(4),Constr(S, [Var(5)])]))) 337 | } 338 | ]) 339 | }}, 340 | {1, {Var(1), RLetIn(Var(1), 11, Var(2), LeftE(Var(2)))} }]} 341 | 342 | 343 | fromValue Z =^= ConstrV(Z,[]) 344 | fromValue S(n) =^= 345 | let v = fromValue n 346 | in ConstrV(S, [v]) 347 | fromValue {x,y} =^= 348 | let x' = fromValue x 349 | y' = fromValue y 350 | in ConstrV(Tuple, [x',y']) 351 | fromValue {x} =^= 352 | let x' = fromValue x 353 | in ConstrV(Tuple, [x']) 354 | fromValue (x:xs) =^= 355 | let x' = fromValue x 356 | xs' = fromValue xs 357 | in ConstrV(Cons, [x',xs']) 358 | fromValue [] =^= ConstrV(Nil, []) 359 | fromValue (Even(x)) =^= 360 | let x' = fromValue x 361 | in ConstrV(Even, [x']) 362 | fromValue (Odd(x)) =^= 363 | let x' = fromValue x 364 | in ConstrV(Odd, [x']) 365 | 366 | 367 | testFib input =^= 368 | let {ident, funEnv} = fib 1 369 | value = fromValue input 370 | {funEnv', ident', value'} = eval {funEnv, ident, value} 371 | rlet {ident', funEnv'} = fib 1 372 | value' = fromValue output 373 | in output 374 | 375 | fib x =^= {x,[{1,{Var(2),CaseOf(Var(2),[{Constr(Z,[]),LeftE(Constr(Tuple,[Constr(S,[Constr(Z,[])]),Constr(S,[Constr(Z,[])])]))},{Constr(S,[Var(3)]),LetIn(Constr(Tuple,[Var(2),Var(4)]),1,Var(3),LetIn(Var(6),5,Constr(Tuple,[Var(4),Var(2)]),LeftE(Var(6))))}])}}, 376 | {4,{Var(2),CaseOf(Var(2),[{Constr(Tuple,[Var(2),Constr(Z,[])]),LeftE(DupEq(Constr(Tuple,[Var(2)])))},{Constr(Tuple,[Var(2),Constr(S,[Var(10)])]),LetIn(Constr(Tuple,[Var(11),Var(12)]),5,Constr(Tuple,[Var(2),Var(10)]),LeftE(Constr(Tuple,[Var(11),Constr(S,[Var(12)])])))}])}}, 377 | {2,{Var(8),RLetIn(Var(8),5,Var(9),LeftE(Var(9)))}}]} 378 | 379 | 380 | testFilter input =^= 381 | let {ident, funEnv} = filter 1 382 | value = fromValue input 383 | {funEnv', ident', value'} = eval {funEnv, ident, value} 384 | rlet {ident', funEnv'} = filter 1 385 | value' = fromValue output 386 | in output 387 | 388 | 389 | filter x =^= {x,[{1,{Constr(Tuple,[Var(10),Var(11)]),LetIn(Var(13),12,Var(10),LetIn(Constr(Tuple,[Var(15),Var(16)]),14,Constr(Tuple,[Var(13),Var(11)]),RLetIn(Var(15),12,Var(17),LeftE(Constr(Tuple,[Var(17),Var(16)])))))}}, 390 | {1,{Var(3),CaseOf(DupEq(Var(3)),[{Var(4),LeftE(Var(4))}])}}, 391 | {3,{Var(6),CaseOf(Var(6),[{Constr(Z,[]),LeftE(Constr(Even,[Constr(Z,[])]))},{Constr(S,[Constr(Z,[])]),LeftE(Constr(Odd,[Constr(S,[Constr(Z,[])])]))},{Constr(S,[Constr(S,[Var(7)])]),LetIn(Var(8),5,Var(7),CaseOf(Var(8),[{Constr(Even,[Var(9)]),LeftE(Constr(Even,[Constr(S,[Constr(S,[Var(9)])])]))},{Constr(Odd,[Var(9)]),LeftE(Constr(Odd,[Constr(S,[Constr(S,[Var(9)])])]))}]))}])}}, 392 | {7,{Var(6),CaseOf(Var(6),[{Constr(Nil,[]),LeftE(Constr(Nil,[]))},{Constr(Cons,[Var(7),Var(22)]),LetIn(Var(23),5,Var(7),LetIn(Var(13),12,Var(22),LeftE(Constr(Cons,[Var(23),Var(13)]))))}])}}, 393 | {2,{Var(6),CaseOf(Var(6),[{Constr(Tuple,[Constr(Nil,[]),Var(11)]),LeftE(Constr(Tuple,[Constr(Nil,[]),Var(11)]))},{Constr(Tuple,[Constr(Cons,[Var(18),Var(10)]),Constr(Nil,[])]),LeftE(Constr(Tuple,[Constr(Cons,[Var(18),Var(10)]),Constr(Nil,[])]))},{Constr(Tuple,[Constr(Cons,[Var(18),Var(10)]),Constr(Cons,[Var(3),Var(11)])]),CaseOf(Var(18),[{Constr(Odd,[Var(19)]),LetIn(Constr(Tuple,[Var(17),Var(16)]),14,Constr(Tuple,[Var(10),Constr(Cons,[Var(3),Var(11)])]),LetIn(Constr(Tuple,[Var(20),Var(21)]),2,Constr(Tuple,[Var(19)]),LeftE(Constr(Tuple,[Constr(Cons,[Constr(Odd,[Var(20)]),Var(17)]),Constr(Cons,[Var(21),Var(16)])]))))},{Constr(Even,[Var(19)]),LetIn(Constr(Tuple,[Var(17),Var(16)]),14,Constr(Tuple,[Var(10),Var(11)]),LeftE(Constr(Tuple,[Constr(Cons,[Constr(Even,[Var(19)]),Var(17)]),Constr(Cons,[Var(3),Var(16)])])))}])}])}}]} 394 | 395 | 396 | testSelf input =^= 397 | let {ident, funEnv} = self 1 398 | value = fromValue input 399 | {funEnv', ident', value'} = eval {funEnv, ident, value} 400 | rlet {ident', funEnv'} = self 1 401 | value' = fromValue output 402 | in output 403 | 404 | -- x == 1 405 | self x =^= {x,[{1,{Var(133),LetIn(Constr(Tuple,[Var(29),Var(60)]),124,Constr(Z,[]),LetIn(Var(10),123,Var(133),LetIn(Constr(Tuple,[Var(66),Var(63),Var(18)]),59,Constr(Tuple,[Var(29),Var(60),Var(10)]),RLetIn(Constr(Tuple,[Var(63),Var(66)]),124,Constr(Z,[]),RLetIn(Var(18),123,Var(134),LeftE(Var(134)))))))}}, 406 | {1,{Var(3),RLetIn(Var(3),4,Var(5),LeftE(Var(5)))}}, 407 | {2,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Z,[]),Constr(Cons,[Constr(Z,[]),Var(14)])]),LeftE(Constr(Tuple,[Constr(Z,[]),Var(14)]))},{Constr(Tuple,[Constr(S,[Var(126)]),Constr(Cons,[Constr(Z,[]),Var(14)])]),LetIn(Constr(Tuple,[Var(127),Var(54)]),4,Constr(Tuple,[Constr(S,[Var(126)]),Var(14)]),LeftE(Constr(Tuple,[Var(127),Constr(Cons,[Constr(Z,[]),Var(54)])])))},{Constr(Tuple,[Constr(S,[Var(126)]),Constr(Cons,[Constr(S,[Var(129)]),Var(14)])]),LetIn(Constr(Tuple,[Var(127),Var(79)]),4,Constr(Tuple,[Var(126),Constr(Cons,[Var(129),Var(14)])]),CaseOf(Var(79),[{Constr(Nil,[]),LeftE(Constr(Tuple,[Constr(S,[Var(127)]),Constr(Nil,[])]))},{Constr(Cons,[Var(130),Var(54)]),LeftE(Constr(Tuple,[Constr(S,[Var(127)]),Constr(Cons,[Constr(S,[Var(130)]),Var(54)])]))}]))}])}}, 408 | {2,{Constr(Tuple,[Constr(Cons,[Constr(Tuple,[Var(7),Var(8)]),Var(9)]),Var(10)]),LetIn(Var(12),11,Constr(Tuple,[Var(7),Var(10)]),CaseOf(Var(12),[{Constr(Right,[Var(13),Var(14)]),LetIn(Constr(Tuple,[Var(16),Var(17)]),15,Constr(Tuple,[Constr(Tuple,[Var(13),Var(8)])]),LeftE(Constr(Tuple,[Constr(Z,[]),Var(16),Constr(Cons,[Var(17),Var(9)]),Var(14)])))},{Constr(Left,[Var(13),Var(18)]),LetIn(Constr(Tuple,[Var(19),Var(20),Var(21),Var(14)]),6,Constr(Tuple,[Var(9),Var(18)]),LeftE(Constr(Tuple,[Constr(S,[Var(19)]),Var(20),Constr(Cons,[Constr(Tuple,[Var(13),Var(8)]),Var(21)]),Var(14)])))}]))}}, 409 | {5,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Var,[Var(44)]),Var(10)]),LetIn(Constr(Tuple,[Var(56),Var(54)]),55,Constr(Tuple,[Constr(Tuple,[Var(44),Var(10)]),Constr(Nil,[])]),LeftE(Constr(Right,[Constr(Var,[Var(56)]),Var(54)])))},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Nil,[])]),Constr(ConstrV,[Var(111),Constr(Nil,[])])]),CaseOf(DupEq(Constr(Tuple,[Var(110),Var(111)])),[{Constr(Tuple,[Var(112)]),LeftE(Constr(Right,[Constr(Constr,[Var(112),Constr(Nil,[])]),Constr(Nil,[])]))},{Constr(Tuple,[Var(112),Var(113)]),LeftE(Constr(Left,[Constr(Constr,[Var(112),Constr(Nil,[])]),Constr(ConstrV,[Var(113),Constr(Nil,[])])]))}])},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Nil,[])]),Constr(ConstrV,[Var(111),Constr(Cons,[Var(3),Var(114)])])]),LeftE(Constr(Left,[Constr(Constr,[Var(110),Constr(Nil,[])]),Constr(ConstrV,[Var(111),Constr(Cons,[Var(3),Var(114)])])]))},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Cons,[Var(3),Var(115)])]),Constr(ConstrV,[Var(111),Constr(Nil,[])])]),LeftE(Constr(Left,[Constr(Constr,[Var(110),Constr(Cons,[Var(3),Var(115)])]),Constr(ConstrV,[Var(111),Constr(Nil,[])])]))},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Cons,[Var(3),Var(115)])]),Constr(ConstrV,[Var(111),Constr(Cons,[Var(116),Var(114)])])]),LetIn(Var(33),11,Constr(Tuple,[Var(3),Var(116)]),LetIn(Var(34),11,Constr(Tuple,[Constr(Constr,[Var(110),Var(115)]),Constr(ConstrV,[Var(111),Var(114)])]),CaseOf(Constr(Tuple,[Var(33),Var(34)]),[{Constr(Tuple,[Constr(Right,[Var(5),Var(54)]),Constr(Right,[Constr(Constr,[Var(112),Var(117)]),Var(57)])]),LetIn(Constr(Tuple,[Var(79),Var(14)]),40,Constr(Tuple,[Var(54),Var(57)]),RLetIn(Constr(Tuple,[Var(5),Var(79)]),81,Constr(Tuple,[Var(118),Constr(Nil,[])]),LeftE(Constr(Right,[Constr(Constr,[Var(112),Constr(Cons,[Var(118),Var(117)])]),Var(14)]))))},{Constr(Tuple,[Var(36),Var(37)]),RLetIn(Var(36),11,Constr(Tuple,[Var(5),Var(119)]),RLetIn(Var(37),11,Constr(Tuple,[Constr(Constr,[Var(112),Var(117)]),Constr(ConstrV,[Var(113),Var(120)])]),LeftE(Constr(Left,[Constr(Constr,[Var(112),Constr(Cons,[Var(5),Var(117)])]),Constr(ConstrV,[Var(113),Constr(Cons,[Var(119),Var(120)])])]))))}])))},{Constr(Tuple,[Constr(DupEq,[Var(79)]),Var(10)]),LetIn(Var(18),75,Var(10),LetIn(Var(12),11,Constr(Tuple,[Var(79),Var(18)]),CaseOf(Var(12),[{Constr(Right,[Var(80),Var(54)]),LeftE(Constr(Right,[Constr(DupEq,[Var(80)]),Var(54)]))},{Constr(Left,[Var(80),Var(25)]),RLetIn(Var(25),75,Var(38),LeftE(Constr(Left,[Constr(DupEq,[Var(80)]),Var(38)])))}])))}])}}, 410 | {4,{Var(3),CaseOf(DupEq(Var(3)),[{Var(5),LeftE(Var(5))}])}}, 411 | {7,{Constr(Tuple,[Constr(Cons,[Constr(Tuple,[Var(7),Var(8)]),Var(9)]),Var(10)]),LetIn(Var(12),23,Constr(Tuple,[Var(8),Var(10)]),CaseOf(Var(12),[{Constr(Tuple,[Constr(Right,[Var(24)]),Var(18)]),LetIn(Constr(Tuple,[Var(16),Var(17)]),15,Constr(Tuple,[Constr(Tuple,[Var(7),Var(24)])]),LeftE(Constr(Tuple,[Constr(Z,[]),Var(16),Constr(Cons,[Var(17),Var(9)]),Var(18)])))},{Constr(Tuple,[Constr(Left,[Var(24)]),Var(18)]),LetIn(Constr(Tuple,[Var(19),Var(20),Var(21),Var(25)]),22,Constr(Tuple,[Var(9),Var(18)]),LeftE(Constr(Tuple,[Constr(S,[Var(19)]),Var(20),Constr(Cons,[Constr(Tuple,[Var(7),Var(24)]),Var(21)]),Var(25)])))}]))}}, 412 | {1,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(LeftE,[Var(7)]),Var(10)]),LetIn(Var(12),11,Constr(Tuple,[Var(7),Var(10)]),CaseOf(Var(12),[{Constr(Right,[Var(13),Var(14)]),RLetIn(Constr(Right,[Var(13),Var(14)]),11,Constr(Tuple,[Var(27),Var(18)]),LeftE(Constr(Tuple,[Constr(Right,[Constr(LeftE,[Var(27)])]),Var(18)])))},{Constr(Left,[Var(13),Var(18)]),LeftE(Constr(Tuple,[Constr(Left,[Constr(LeftE,[Var(13)])]),Var(18)]))}]))},{Constr(Tuple,[Constr(LetIn,[Var(28),Var(29),Var(30),Var(8)]),Var(10)]),LetIn(Var(12),23,Constr(Tuple,[Var(8),Var(10)]),CaseOf(Var(12),[{Constr(Tuple,[Constr(Right,[Var(24)]),Var(18)]),LeftE(Constr(Tuple,[Constr(Right,[Constr(LetIn,[Var(28),Var(29),Var(30),Var(24)])]),Var(18)]))},{Constr(Tuple,[Constr(Left,[Var(24)]),Var(18)]),LeftE(Constr(Tuple,[Constr(Left,[Constr(LetIn,[Var(28),Var(29),Var(30),Var(24)])]),Var(18)]))}]))},{Constr(Tuple,[Constr(RLetIn,[Var(28),Var(29),Var(30),Var(8)]),Var(10)]),LetIn(Var(12),23,Constr(Tuple,[Var(8),Var(10)]),CaseOf(Var(12),[{Constr(Tuple,[Constr(Right,[Var(24)]),Var(18)]),LeftE(Constr(Tuple,[Constr(Right,[Constr(RLetIn,[Var(28),Var(29),Var(30),Var(24)])]),Var(18)]))},{Constr(Tuple,[Constr(Left,[Var(24)]),Var(18)]),LeftE(Constr(Tuple,[Constr(Left,[Constr(RLetIn,[Var(28),Var(29),Var(30),Var(24)])]),Var(18)]))}]))},{Constr(Tuple,[Constr(CaseOf,[Var(7),Constr(Nil,[])]),Var(10)]),LeftE(Constr(Tuple,[Constr(Left,[Constr(CaseOf,[Var(7),Constr(Nil,[])])]),Var(10)]))},{Constr(Tuple,[Constr(CaseOf,[Var(7),Constr(Cons,[Constr(Tuple,[Var(31),Var(32)]),Var(9)])]),Var(10)]),LetIn(Constr(Tuple,[Var(33),Var(18)]),23,Constr(Tuple,[Var(32),Var(10)]),LetIn(Constr(Tuple,[Var(34),Var(25)]),23,Constr(Tuple,[Constr(CaseOf,[Var(7),Var(9)]),Var(18)]),CaseOf(Constr(Tuple,[Var(33),Var(34)]),[{Constr(Tuple,[Constr(Left,[Var(35)]),Constr(Left,[Constr(CaseOf,[Var(13),Var(21)])])]),LeftE(Constr(Tuple,[Constr(Left,[Constr(CaseOf,[Var(13),Constr(Cons,[Constr(Tuple,[Var(31),Var(35)]),Var(21)])])]),Var(25)]))},{Constr(Tuple,[Var(36),Var(37)]),RLetIn(Constr(Tuple,[Var(37),Var(25)]),23,Constr(Tuple,[Constr(CaseOf,[Var(13),Var(21)]),Var(38)]),RLetIn(Constr(Tuple,[Var(36),Var(38)]),23,Constr(Tuple,[Var(35),Var(39)]),LeftE(Constr(Tuple,[Constr(Right,[Constr(CaseOf,[Var(13),Constr(Cons,[Constr(Tuple,[Var(31),Var(35)]),Var(21)])])]),Var(39)]))))}])))}])}}, 413 | {17,{Constr(Tuple,[Var(41),Var(42)]),LetIn(Constr(Tuple,[Var(44),Var(3)]),43,Var(41),LetIn(Constr(Tuple,[Constr(Z,[]),Var(46)]),45,Constr(Tuple,[Constr(Z,[]),Var(44)]),LetIn(Var(48),47,Constr(Tuple,[Var(46),Var(3)]),LetIn(Constr(Tuple,[Var(50),Var(14)]),49,Constr(Tuple,[Var(48),Var(42)]),RLetIn(Constr(Tuple,[Constr(Z,[]),Var(50)]),45,Constr(Tuple,[Constr(Z,[]),Var(51)]),LeftE(Constr(Tuple,[Var(51),Var(14)])))))))}}, 414 | {3,{Var(3),RLetIn(Var(3),47,Var(5),LeftE(Var(5)))}}, 415 | {2,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Var(98),Constr(Nil,[])]),LeftE(Constr(Tuple,[Var(98),Constr(Nil,[])]))},{Constr(Tuple,[Var(98),Constr(Cons,[Var(44),Var(52)])]),LetIn(Constr(Tuple,[Var(132),Var(56)]),131,Constr(Tuple,[Var(98),Var(44)]),LetIn(Constr(Tuple,[Var(78),Var(79)]),45,Constr(Tuple,[Var(56),Var(52)]),LeftE(Constr(Tuple,[Var(132),Constr(Cons,[Var(78),Var(79)])]))))}])}}, 416 | {2,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Nil,[]),Constr(Nil,[])]),LeftE(Constr(Nil,[]))},{Constr(Tuple,[Constr(Cons,[Var(44),Var(52)]),Constr(Cons,[Var(76),Var(135)])]),LetIn(Var(136),47,Constr(Tuple,[Var(52),Var(135)]),LeftE(Constr(Cons,[Constr(Tuple,[Var(44),Var(76)]),Var(136)])))}])}}, 417 | {2,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Nil,[]),Var(14)]),LeftE(Constr(Tuple,[Constr(Nil,[]),Var(14)]))},{Constr(Tuple,[Constr(Cons,[Var(44),Var(52)]),Var(14)]),LetIn(Constr(Tuple,[Var(53),Var(54)]),49,Constr(Tuple,[Var(52),Var(14)]),LetIn(Constr(Tuple,[Var(56),Var(57)]),55,Constr(Tuple,[Var(44),Var(54)]),LeftE(Constr(Tuple,[Constr(Cons,[Var(56),Var(53)]),Var(57)]))))}])}}, 418 | {6,{Var(3),RLetIn(Var(3),125,Var(5),LeftE(Var(5)))}}, 419 | {3,{Var(3),RLetIn(Var(3),40,Var(5),LeftE(Var(5)))}}, 420 | {1,{Constr(Tuple,[Var(29),Var(60),Var(61)]),LetIn(Constr(Tuple,[Var(63),Constr(Tuple,[Var(64),Var(65)]),Var(66)]),62,Constr(Tuple,[Var(29),Var(60)]),LetIn(Constr(Right,[Var(67),Var(68)]),11,Constr(Tuple,[Var(64),Var(61)]),LetIn(Constr(Tuple,[Var(70),Var(71),Var(72)]),69,Constr(Tuple,[Var(65),Var(66),Var(68)]),RLetIn(Constr(Tuple,[Var(63),Constr(Tuple,[Var(67),Var(70)]),Var(71)]),62,Constr(Tuple,[Var(73),Var(74)]),LeftE(Constr(Tuple,[Var(74),Var(73),Var(72)]))))))}}, 421 | {3,{Constr(Tuple,[Var(29),Var(60)]),LetIn(Constr(Tuple,[Constr(Tuple,[Var(63),Var(3)]),Var(66)]),125,Constr(Tuple,[Var(29),Var(60)]),LetIn(Constr(Tuple,[Var(5),Var(118)]),15,Constr(Tuple,[Var(3)]),LetIn(Constr(Tuple,[Var(73),Var(71)]),55,Constr(Tuple,[Constr(Tuple,[Var(63),Var(5)]),Var(66)]),LeftE(Constr(Tuple,[Var(73),Var(118),Var(71)])))))}}, 422 | {7,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(LeftE,[Var(79)]),Var(60),Var(14)]),RLetIn(Constr(Right,[Var(79),Var(14)]),11,Constr(Tuple,[Var(80),Var(10)]),LeftE(Constr(Tuple,[Constr(LeftE,[Var(80)]),Var(60),Var(10)])))},{Constr(Tuple,[Constr(LetIn,[Var(28),Var(29),Var(30),Var(8)]),Var(60),Var(14)]),LetIn(Constr(Tuple,[Var(82),Var(83)]),81,Constr(Tuple,[Var(30),Constr(Nil,[])]),LetIn(Constr(Tuple,[Var(84),Var(85)]),58,Constr(Tuple,[Var(83),Var(14)]),LetIn(Constr(Tuple,[Var(66),Var(63),Var(87),Var(88)]),86,Constr(Tuple,[Var(60),Var(29),Var(82),Var(84)]),LetIn(Constr(Right,[Var(89),Var(90)]),11,Constr(Tuple,[Var(28),Var(88)]),LetIn(Constr(Tuple,[Var(91),Var(92)]),40,Constr(Tuple,[Var(90),Var(85)]),RLetIn(Constr(Tuple,[Var(89),Var(91)]),81,Constr(Tuple,[Var(93),Constr(Nil,[])]),LetIn(Constr(Tuple,[Var(24),Var(71),Var(3)]),69,Constr(Tuple,[Var(8),Var(66),Var(92)]),LeftE(Constr(Tuple,[Constr(LetIn,[Var(93),Var(63),Var(87),Var(24)]),Var(71),Var(3)])))))))))},{Constr(Tuple,[Constr(RLetIn,[Var(30),Var(29),Var(28),Var(8)]),Var(60),Var(14)]),RLetIn(Constr(Tuple,[Constr(LetIn,[Var(30),Var(29),Var(28),Var(8)]),Var(60),Var(14)]),69,Constr(Tuple,[Constr(LetIn,[Var(82),Var(63),Var(89),Var(24)]),Var(66),Var(10)]),LeftE(Constr(Tuple,[Constr(RLetIn,[Var(82),Var(63),Var(89),Var(24)]),Var(66),Var(10)])))},{Constr(Tuple,[Constr(CaseOf,[Var(7),Var(9)]),Var(60),Var(14)]),LetIn(Constr(Tuple,[Var(13),Var(94)]),81,Constr(Tuple,[Var(7),Constr(Nil,[])]),LetIn(Constr(Tuple,[Var(95),Var(96)]),58,Constr(Tuple,[Var(94),Var(14)]),LetIn(Constr(Tuple,[Constr(LeftE,[Var(27)]),Var(66),Var(97)]),69,Constr(Tuple,[Constr(LeftE,[Var(13)]),Var(60),Var(95)]),LetIn(Constr(Tuple,[Var(98),Constr(Tuple,[Var(99),Var(100)]),Var(21),Var(101)]),6,Constr(Tuple,[Var(9),Var(97)]),LetIn(Constr(Tuple,[Var(102),Var(103)]),40,Constr(Tuple,[Var(101),Var(96)]),RLetIn(Constr(Tuple,[Var(99),Var(102)]),81,Constr(Tuple,[Var(104),Constr(Nil,[])]),LetIn(Constr(Tuple,[Var(105),Var(71),Var(10)]),69,Constr(Tuple,[Var(100),Var(66),Var(103)]),RLetIn(Constr(Tuple,[Var(98),Constr(Tuple,[Var(104),Var(105)]),Var(21),Var(10)]),22,Constr(Tuple,[Var(106),Var(18)]),LeftE(Constr(Tuple,[Constr(CaseOf,[Var(27),Var(106)]),Var(71),Var(18)]))))))))))}])}}, 423 | {6,{Var(26),CaseOf(Var(26),[{Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(44),Constr(Cons,[Var(76),Constr(Nil,[])])])]),CaseOf(DupEq(Constr(Tuple,[Var(44),Var(76)])),[{Constr(Tuple,[Var(56)]),LeftE(Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(56),Constr(Nil,[])])]))},{Constr(Tuple,[Var(56),Var(77)]),LeftE(Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(56),Constr(Cons,[Var(77),Constr(Nil,[])])])]))}])},{Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(44),Constr(Nil,[])])]),LetIn(Constr(Tuple,[Var(56),Var(78)]),15,Constr(Tuple,[Var(44)]),LeftE(Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(56),Constr(Cons,[Var(78),Constr(Nil,[])])])])))}])}}, 424 | {6,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Var,[Var(44)]),Var(51)]),LetIn(Constr(Tuple,[Var(56),Var(121)]),2,Constr(Tuple,[Var(44),Var(51)]),LeftE(Constr(Tuple,[Constr(Var,[Var(56)]),Var(121)])))},{Constr(Tuple,[Constr(DupEq,[Var(79)]),Var(51)]),LetIn(Constr(Tuple,[Var(80),Var(121)]),81,Constr(Tuple,[Var(79),Var(51)]),LeftE(Constr(Tuple,[Constr(DupEq,[Var(80)]),Var(121)])))},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Nil,[])]),Var(51)]),LeftE(Constr(Tuple,[Constr(Constr,[Var(110),Constr(Nil,[])]),Var(51)]))},{Constr(Tuple,[Constr(Constr,[Var(110),Constr(Cons,[Var(3),Var(115)])]),Var(51)]),LetIn(Constr(Tuple,[Var(5),Var(121)]),81,Constr(Tuple,[Var(3),Var(51)]),LetIn(Constr(Tuple,[Constr(Constr,[Var(112),Var(117)]),Var(122)]),81,Constr(Tuple,[Constr(Constr,[Var(110),Var(115)]),Var(121)]),LeftE(Constr(Tuple,[Constr(Constr,[Var(112),Constr(Cons,[Var(5),Var(117)])]),Var(122)]))))}])}}, 425 | {5,{Constr(Tuple,[Var(60),Var(29),Var(107),Var(14)]),LetIn(Constr(Tuple,[Var(63),Constr(Tuple,[Var(64),Var(65)]),Var(66)]),62,Constr(Tuple,[Var(29),Var(60)]),LetIn(Constr(Tuple,[Constr(LeftE,[Var(108)]),Var(71),Var(5)]),69,Constr(Tuple,[Constr(LeftE,[Var(107)]),Var(66),Var(14)]),LetIn(Constr(Right,[Var(67),Var(68)]),11,Constr(Tuple,[Var(64),Var(5)]),LetIn(Constr(Tuple,[Var(70),Var(74),Var(10)]),69,Constr(Tuple,[Var(65),Var(71),Var(68)]),RLetIn(Constr(Tuple,[Var(63),Constr(Tuple,[Var(67),Var(70)]),Var(74)]),62,Constr(Tuple,[Var(73),Var(109)]),LeftE(Constr(Tuple,[Var(109),Var(73),Var(108),Var(10)])))))))}}, 426 | {37,{Var(26),CaseOf(Var(26),[{Constr(Z,[]),LeftE(Constr(ConstrV,[Constr(Z,[]),Constr(Nil,[])]))},{Constr(S,[Var(19)]),LetIn(Var(3),123,Var(19),LeftE(Constr(ConstrV,[Constr(S,[]),Constr(Cons,[Var(3),Constr(Nil,[])])])))},{Constr(Tuple,[Var(44),Var(76)]),LetIn(Var(56),123,Var(44),LetIn(Var(77),123,Var(76),LeftE(Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(56),Constr(Cons,[Var(77),Constr(Nil,[])])])]))))},{Constr(Tuple,[Var(44)]),LetIn(Var(56),123,Var(44),LeftE(Constr(ConstrV,[Constr(Tuple,[]),Constr(Cons,[Var(56),Constr(Nil,[])])])))},{Constr(Cons,[Var(44),Var(52)]),LetIn(Var(56),123,Var(44),LetIn(Var(53),123,Var(52),LeftE(Constr(ConstrV,[Constr(Cons,[]),Constr(Cons,[Var(56),Constr(Cons,[Var(53),Constr(Nil,[])])])]))))},{Constr(Nil,[]),LeftE(Constr(ConstrV,[Constr(Nil,[]),Constr(Nil,[])]))}])}}, 427 | 428 | {1,{Var(44),LeftE(Constr(Tuple,[Var(44),Constr(Cons,[Constr(Tuple,[Constr(Z,[]),Constr(Tuple,[Constr(Var,[Constr(S,[Constr(Z,[])])]),Constr(CaseOf,[Constr(Var,[Constr(S,[Constr(Z,[])])]),Constr(Cons,[Constr(Tuple,[Constr(Constr,[Constr(Z,[]),Constr(Nil,[])]),Constr(LeftE,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Constr,[Constr(Z,[]),Constr(Nil,[])]),Constr(Nil,[])])])])]),Constr(Cons,[Constr(Tuple,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Var,[Constr(S,[Constr(S,[Constr(Z,[])])])]),Constr(Nil,[])])]),Constr(LetIn,[Constr(Var,[Constr(S,[Constr(S,[Constr(S,[Constr(Z,[])])])])]),Constr(Z,[]),Constr(Var,[Constr(S,[Constr(S,[Constr(Z,[])])])]),Constr(LeftE,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Var,[Constr(S,[Constr(S,[Constr(S,[Constr(Z,[])])])])]),Constr(Nil,[])])])])])]),Constr(Nil,[])])])])])]),Constr(Nil,[])])]))}}, 429 | 430 | 431 | {1,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Z,[]),Constr(Cons,[Constr(Tuple,[Constr(Z,[]),Var(3)]),Var(14)])]),LeftE(Constr(Tuple,[Constr(Tuple,[Constr(Z,[]),Var(3)]),Var(14)]))},{Constr(Tuple,[Constr(S,[Var(126)]),Constr(Cons,[Constr(Tuple,[Constr(Z,[]),Var(3)]),Var(14)])]),LetIn(Constr(Tuple,[Constr(Tuple,[Var(127),Var(128)]),Var(54)]),125,Constr(Tuple,[Constr(S,[Var(126)]),Var(14)]),LeftE(Constr(Tuple,[Constr(Tuple,[Var(127),Var(128)]),Constr(Cons,[Constr(Tuple,[Constr(Z,[]),Var(3)]),Var(54)])])))},{Constr(Tuple,[Constr(S,[Var(126)]),Constr(Cons,[Constr(Tuple,[Constr(S,[Var(129)]),Var(3)]),Var(14)])]),LetIn(Constr(Tuple,[Constr(Tuple,[Var(127),Var(128)]),Var(79)]),125,Constr(Tuple,[Var(126),Constr(Cons,[Constr(Tuple,[Var(129),Var(3)]),Var(14)])]),CaseOf(Var(79),[{Constr(Nil,[]),LeftE(Constr(Tuple,[Constr(Tuple,[Constr(S,[Var(127)]),Var(128)]),Constr(Nil,[])]))},{Constr(Cons,[Constr(Tuple,[Var(130),Var(3)]),Var(54)]),LeftE(Constr(Tuple,[Constr(Tuple,[Constr(S,[Var(127)]),Var(128)]),Constr(Cons,[Constr(Tuple,[Constr(S,[Var(130)]),Var(3)]),Var(54)])]))}]))}])}}, 432 | {6,{Var(26),CaseOf(Var(26),[{Constr(Tuple,[Constr(Z,[]),Var(76)]),LeftE(Constr(Tuple,[Constr(Z,[]),Var(76)]))},{Constr(Tuple,[Constr(S,[Var(44)]),Var(76)]),LetIn(Constr(Tuple,[Var(56),Var(77)]),131,Constr(Tuple,[Var(44),Var(76)]),LeftE(Constr(Tuple,[Constr(S,[Var(56)]),Constr(S,[Var(77)])])))}])}}]} 433 | 434 | --{1,{Var(44),LeftE(Constr(Tuple,[Var(44),Constr(Cons,[Constr(Tuple,[Constr(Z,[]),Constr(Tuple,[Constr(Var,[Constr(S,[Constr(Z,[])])]),Constr(CaseOf,[Constr(Var,[Constr(S,[Constr(Z,[])])]),Constr(Cons,[Constr(Tuple,[Constr(Constr,[Constr(Z,[]),Constr(Nil,[])]),Constr(LeftE,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Constr,[Constr(Z,[]),Constr(Nil,[])]),Constr(Nil,[])])])])]),Constr(Cons,[Constr(Tuple,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Var,[Constr(S,[Constr(S,[Constr(Z,[])])])]),Constr(Nil,[])])]),Constr(LetIn,[Constr(Var,[Constr(S,[Constr(S,[Constr(S,[Constr(Z,[])])])])]),Constr(Z,[]),Constr(Var,[Constr(S,[Constr(S,[Constr(Z,[])])])]),Constr(LeftE,[Constr(Constr,[Constr(S,[]),Constr(Cons,[Constr(Var,[Constr(S,[Constr(S,[Constr(S,[Constr(Z,[])])])])]),Constr(Nil,[])])])])])]),Constr(Nil,[])])])])])]),Constr(Nil,[])])]))}}, 435 | -------------------------------------------------------------------------------- /core_examples/selfInterp_loop.rfun: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------- 2 | -- ** Standard functions 3 | ------------------------------------------------------------------------------- 4 | 5 | -- |Implemententation of |.| as a function 6 | dupEq v =^= 7 | case |v| of 8 | v' -> v' 9 | 10 | dupEqP {Z,Z} =^= {Z} 11 | dupEqP {Z,S(z)} =^= {Z,S(z)} 12 | dupEqP {S(z),Z} =^= {S(z),Z} 13 | dupEqP {S(x),S(y)} =^= 14 | case dupEqP {x,y} 15 | {x'} -> {S(x)} 16 | {x',y'} -> {S(x'),S(y')} 17 | 18 | -- |Zip 19 | zip {[],[]} =^= [] 20 | zip {(x:xs),(y:ys)} =^= 21 | let zs = zip {xs, ys} 22 | in ({x,y}:zs) 23 | 24 | -- |Unzip 25 | unzip v =^= rlet v = zip v' in v' 26 | 27 | -- |Addition 28 | --plus {x, Z } =^= |{x}| 29 | --plus {x,S(u)} =^= 30 | -- let {xp,up} = plus {x,u} 31 | -- in {xp, S(up)} 32 | 33 | plus {Z,y} =^= {Z,y} 34 | plus {S(x), y} =^= 35 | let {x',y'} = plus {x,y} 36 | in {S(x'), S(y')} 37 | 38 | 39 | -- |scanr specialized to plus 40 | scanrPlus {i, []} =^= {i, []} 41 | scanrPlus {i, (x:xs)} =^= 42 | let {i', x'} = plus {i, x} 43 | {x'', l} = scanrPlus {x', xs} 44 | in {i', (x'' : l)} 45 | 46 | ------------------------------------------------------------------------------- 47 | -- ** Substitutions and functions on these 48 | ------------------------------------------------------------------------------- 49 | -- |A substitution is a list of integers to values 50 | -- |The list is ordered and implemented such that the difference (and not the 51 | -- |absolute value) is saved. 52 | --| E.g., in [{1,A}, {1,B}] we have that lookup {1, ..} is A and lookup {2,..} is B 53 | 54 | 55 | -- Perhaps call then get/put 56 | -- lookup :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 57 | lookup {Z, ({Z,v}:sub)} =^= {{Z,v},sub} 58 | lookup {S(a), ({Z,v}:sub)} =^= 59 | let {{a',r}, sub'} = lookup {S(a), sub} 60 | in {{a',r}, ({Z,v}:sub')} 61 | lookup {S(a), ({S(b),v}:sub)} =^= 62 | let {{a',r}, l} = lookup {a, ({b,v}:sub)} in 63 | case l of 64 | [] -> {{S(a'),r}, []} 65 | ({b',v}:sub') -> {{S(a'),r}, ({S(b'),v}:sub')} 66 | 67 | -- insert :: {{N,a},[{N,a}]} -> {N,[{N,a}]} 68 | insert v =^= rlet v = lookup v' in v' 69 | 70 | -- |This is actually scanr specialised to insert 71 | -- disUnion :: {[{N,a}],[{N,a}]} -> {[N],[{N,a}]} 72 | disUnion {sub1, sub2} =^= 73 | let {x,v} = unzip sub1 74 | {0, xInc} = scanrPlus {0,x} 75 | sub1Inc = zip {xInc,v} 76 | {listInc, sub} = disUnionh {sub1Inc, sub2} 77 | rlet {0 , listInc} = scanrPlus {0, list} 78 | in {list, sub} 79 | 80 | -- | Basically a scanr specialised to insert 81 | disUnionh {[],sub} =^= {[], sub} 82 | disUnionh {(x:xs), sub} =^= 83 | let {xs', sub'} = disUnionh {xs, sub} 84 | {x' , sub''} = insert {x, sub'} 85 | in {(x' : xs'), sub''} 86 | 87 | -- divide :: {[N],[{N,a}]} -> {[{N,a}],[{N,a}]} 88 | divide v =^= rlet v = disUnion v' in v' 89 | 90 | -- |Similar to lookup, but copies and inserts the found value again 91 | -- loopupFun :: {N,[{N,a}]} -> {{N,a},[{N,a}]} 92 | lookupFun {ident, funEnv} =^= 93 | let {{ident', v}, funEnv'} = lookup {ident, funEnv} 94 | {v',v''} = dupEq {v} 95 | {ident'',funEnv''} = insert {{ident', v'}, funEnv'} 96 | in {ident'', v'', funEnv''} 97 | 98 | ------------------------------------------------------------------------------- 99 | -- ** Finding variables 100 | ------------------------------------------------------------------------------- 101 | 102 | -- |This function is similar to lookup, but without a value 103 | remove {Z, (Z:sub)} =^= {Z,sub} 104 | remove {S(a), (Z:sub)} =^= 105 | let {a', sub'} = remove {S(a), sub} 106 | in {a', (Z:sub')} 107 | remove {S(a), (S(b):sub)} =^= 108 | let {a', l} = remove {a, (b:sub)} in 109 | case l of 110 | [] -> {S(a'), []} 111 | (b':sub') -> {S(a'), (S(b'):sub')} 112 | 113 | add v =^= rlet v = remove v' in v' 114 | 115 | -- |Find the variables in a give left-expression 116 | -- findvars :: {LExpr, [N]} -> {LExpr, [N]} 117 | findvars {Var(x),list} =^= 118 | let {x',list'} = add {x,list} 119 | in {Var(x'), list'} 120 | findvars {DupEq(l), list} =^= 121 | let {l',list'} = findvars {l,list} 122 | in {DupEq(l'), list'} 123 | -- The following to would be better implemented with a map function 124 | findvars {Constr(c,[]),list} =^= {Constr(c,[]),list} 125 | findvars {Constr(c,(v:vars)),list} =^= 126 | let {v', list'} = findvars {v,list} 127 | {Constr(c',vars'), list''} = findvars {Constr(c,vars), list'} 128 | in {Constr(c',(v':vars')), list''} 129 | 130 | ------------------------------------------------------------------------------- 131 | -- ** The interpreter 132 | ------------------------------------------------------------------------------- 133 | 134 | -- evalDupEq :: Value -> Value 135 | evalDupEq ConstrV(Tuple,[x,y]) =^= 136 | case |{x,y}| of 137 | {x'} -> ConstrV(Tuple,[x']) 138 | {x',y'} -> ConstrV(Tuple,[x',y']) 139 | evalDupEq ConstrV(Tuple,[x]) =^= 140 | let {x', x''} = dupEq {x} 141 | in ConstrV(Tuple,[x',x'']) 142 | 143 | -- |evalRMatch have to be lifted to the "Either monad", as 144 | -- | it is used to find minimum match. LExpr are always unchanged. 145 | -- evalRMatch :: {LExpr, Value} -> Either({LExpr,Value},{LExpr,Subst}) 146 | evalRMatch {Var(x),value} =^= 147 | let {x',sub'} = insert {{x,value},[]} 148 | in Right(Var(x'),sub') 149 | evalRMatch {Constr(c,[]),ConstrV(cV,[])} =^= 150 | case |{c,cV}| of 151 | {c'} -> Right(Constr(c',[]), []) 152 | {c',cV'} -> Left(Constr(c',[]),ConstrV(cV',[])) 153 | evalRMatch {Constr(c,[]),ConstrV(cV,(v:varsV))} =^= 154 | Left(Constr(c,[]),ConstrV(cV,(v:varsV))) 155 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,[])} =^= 156 | Left(Constr(c,(v:vars)),ConstrV(cV,[])) 157 | evalRMatch {Constr(c,(v:vars)),ConstrV(cV,(vV:varsV))} =^= 158 | let r1 = evalRMatch {v,vV} 159 | r2 = evalRMatch {Constr(c,vars),ConstrV(cV,varsV)} 160 | in case {r1,r2} of 161 | {Right(v', sub'), Right(Constr(c',vars'), sub'')} -> 162 | let {l,sub} = disUnion {sub',sub''} 163 | rlet {v',l} = findvars {v'',[]} 164 | in Right(Constr(c',(v'':vars')), sub) 165 | {r1',r2'} -> 166 | rlet r1' = evalRMatch {v', vV'} 167 | r2' = evalRMatch {Constr(c',vars'),ConstrV(cV',varsV')} 168 | in Left(Constr(c',(v':vars')), ConstrV(cV',(vV':varsV'))) 169 | evalRMatch {DupEq(l), value} =^= 170 | let value' = evalDupEq value 171 | in case evalRMatch {l, value'} of 172 | Right(l',sub') -> Right(DupEq(l'), sub') 173 | Left(l',value'') -> 174 | rlet value'' = evalDupEq value''' 175 | in Left(DupEq(l'),value''') 176 | 177 | -- |Helper function that evaluates a function. 178 | -- |All inputs are unchanged expect the Subst -> Value 179 | -- evalFun :: {FunEnv, Ident, LExpr, Subst} -> {FunEnv, Ident, LExpr, Value} 180 | evalFun {funEnv, ident, lexpr, sub} =^= 181 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 182 | {LeftE(lexpr'), funEnv'', v'} = evalExp {LeftE(lexpr), funEnv', sub} 183 | Right(funL', sub_f) = evalRMatch {funL, v'} 184 | {funE', funEnv''', value} = evalExp {funE, funEnv'', sub_f} 185 | rlet {ident', {funL', funE'}, funEnv'''} = lookupFun {ident'', funEnv''''} 186 | in {funEnv'''', ident'', lexpr', value} 187 | 188 | evalFunM {funEnv, ident, lexpr, sub} =^= 189 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 190 | {LeftE(lexpr'), funEnv'', v'} = evalExp {LeftE(lexpr), funEnv', sub} 191 | in case evalRMatch {funL, v'} 192 | Right(funL', sub_f) -> 193 | let {funE', funEnv''', value} = evalExp {funE, funEnv'', sub_f} 194 | rlet {ident', {funL', funE'}, funEnv'''} = lookupFun {ident'', funEnv''''} 195 | in {funEnv'''', ident'', lexpr', value} 196 | Left(funL', v'') -> 197 | 198 | 199 | -- |Evaluation of expressions. 200 | -- |All inputs are unchanged expect the Subst -> Value 201 | -- evalExp :: {Expr, FunEnv, Subst} -> {Expr, FunEnv, Value} 202 | evalExp {LeftE(l), funEnv, sub} =^= 203 | rlet Right(l, sub) = evalRMatch {l', value} 204 | in {LeftE(l'), funEnv, value} 205 | evalExp {LetIn(lout, ident, lin, expr), funEnv, sub} =^= 206 | let {lin', v_lin} = findvars {lin,[]} 207 | {sub_in,sub_e} = divide {v_lin, sub} 208 | {funEnv', ident', lin'', vout} = evalFun {funEnv, ident, lin', sub_in} 209 | Right(lout', sub_out) = evalRMatch {lout, vout} 210 | {v_lout, sub_ef} = disUnion {sub_out, sub_e} 211 | rlet {lout', v_lout} = findvars {lout'',[]} 212 | let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 213 | in {LetIn(lout'', ident', lin'', expr'), funEnv'', v} 214 | evalExp {RLetIn(lin, ident, lout, expr), funEnv, sub} =^= 215 | rlet {LetIn(lin, ident, lout, expr), funEnv, sub} = evalExp {LetIn(lin', ident', lout', expr'), funEnv', value} 216 | --let {lin', v_lin} = findvars {lin,[]} 217 | -- {sub_in,sub_e} = divide {v_lin, sub} 218 | --rlet Right(lin', sub_in) = evalRMatch {lin'', vin} 219 | -- {funEnv, ident, lout, vin} = evalFun {funEnv', ident', lout', sub_out} 220 | --let {v_lout, sub_ef} = disUnion {sub_out, sub_e} 221 | --rlet {lout', v_lout} = findvars {lout'',[]} 222 | --let {expr', funEnv'', v} = evalExp {expr, funEnv', sub_ef} 223 | --in {RLetIn(lin'', ident', lout'', expr'), funEnv'', v} 224 | in {RLetIn(lin', ident', lout', expr'), funEnv', value} 225 | evalExp {CaseOf(lExpr, cases), funEnv, sub} =^= 226 | let {lExpr', v_lExpr} = findvars {lExpr,[]} 227 | {sub_l, sub_t} = divide {v_lExpr, sub} 228 | {LeftE(lExpr''), funEnv', vp} = evalExp {LeftE(lExpr'), funEnv, sub_l} 229 | {i, {cLExpr,cExpr}, cases', sub_j} = checkCases {cases, vp} 230 | {v_sub_j,sub_jt} = disUnion {sub_j, sub_t} 231 | rlet {cLExpr, v_sub_j} = findvars {cLExpr',[]} 232 | let {cExpr', funEnv'', value} = evalExp {cExpr, funEnv', sub_jt} 233 | rlet {i,{cLExpr',cExpr'}, cases', value} = checkLeaves {cases'', value'} 234 | in {CaseOf(lExpr'', cases''), funEnv'', value'} 235 | 236 | --evalExp {Loop(lout, ident, lin), funEnv, sub} =^= 237 | -- let {funEnv', ident', lin', vout} = evalFun {funEnv, ident, lin, sub} 238 | -- in 239 | -- case evalRMatch {lout, vout} of 240 | -- Right(lout', sub_out) -> 241 | -- let {Loop(lin'', ident'', lout''), funEnv'', value} = evalExp {Loop(lin', ident', lout'), funEnv', sub_out} 242 | -- in {Loop(lout'', ident'', lin''), funEnv'', value} 243 | -- Left(lout', vout') -> 244 | 245 | 246 | -- | Finds the case (and index) that matches a value and evaluates this to a substitution 247 | -- checkCases :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Subst} 248 | checkCases {({lExpr,expr}:cases), value} =^= 249 | case evalRMatch {lExpr, value} of 250 | Right(lExpr', sub) -> 251 | let {le1,le2} = dupEq {{lExpr',expr}} 252 | in {Z, le1, (le2:cases), sub} 253 | Left(lExpr', value') -> 254 | let {n, le, cases', sub} = checkCases{cases, value'} 255 | in {S(n), le, ({lExpr',expr}:cases'), sub} 256 | 257 | -- | Similar to checkCases, but for leaves of a case instead of case-matches. 258 | -- checkLeaces :: {[{LExpr, Expr}], Value} -> {Int, {LExpr, Expr}, [{LExpr, Expr}], Value} 259 | checkLeaves{({lExpr,expr}:cases), value} =^= 260 | case checkLeavesOf {expr, value} of 261 | {Right(expr'), value'} -> 262 | let {le1,le2} = dupEq {{lExpr,expr'}} 263 | in {Z, le1, (le2:cases), value'} 264 | {Left(expr'), value'} -> 265 | let {n, le, cases', value''} = checkLeaves {cases, value'} 266 | in {S(n), le, ({lExpr,expr'}:cases'), value''} 267 | 268 | -- | Checks if any leaves of an expression matches a given value. 269 | -- checkLeacesOf :: {Expr, Value} -> {Either(Expr, Expr), Value} 270 | checkLeavesOf {LeftE(lExpr), value} =^= 271 | case evalRMatch {lExpr, value} of 272 | Right(lExpr', sub) -> 273 | rlet Right(lExpr', sub) = evalRMatch {lExpr'', value'} 274 | in {Right(LeftE(lExpr'')), value'} 275 | Left(lExpr', value') -> {Left(LeftE(lExpr')), value'} 276 | checkLeavesOf {LetIn(lout, ident, lin, expr), value} =^= 277 | case checkLeavesOf {expr, value} of 278 | {Right(expr'), value'} -> {Right(LetIn(lout, ident, lin, expr')), value'} 279 | {Left(expr'), value'} -> {Left(LetIn(lout, ident, lin, expr')) , value'} 280 | checkLeavesOf {RLetIn(lout, ident, lin, expr), value} =^= 281 | case checkLeavesOf {expr, value} of 282 | {Right(expr'), value'} -> {Right(RLetIn(lout, ident, lin, expr')), value'} 283 | {Left(expr') , value'} -> {Left(RLetIn(lout, ident, lin, expr')) , value'} 284 | checkLeavesOf {CaseOf(lExpr, []), value} =^= 285 | {Left(CaseOf(lExpr, [])), value} 286 | checkLeavesOf {CaseOf(lExpr, ({clExpr,cexpr}:cases)), value} =^= 287 | let {r1, value'} = checkLeavesOf {cexpr, value} 288 | {r2, value''} = checkLeavesOf {CaseOf(lExpr, cases), value'} 289 | in case {r1, r2} of 290 | {Left(cexpr'), Left(CaseOf(lExpr', cases'))} -> 291 | {Left(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''} 292 | {r1',r2'} -> 293 | rlet {r2', value''} = checkLeavesOf {CaseOf(lExpr', cases'), value'''} 294 | {r1', value'''} = checkLeavesOf {cexpr', value''''} 295 | in {Right(CaseOf(lExpr', ({clExpr,cexpr'}:cases'))), value''''} 296 | 297 | -- | The main evaluation function. 298 | -- | Evaluates a given function name in a function environment with a given value 299 | -- | to some output value. function name and environment are unchanged. 300 | -- eval :: {Ident, FunEnv, Value} -> {FunEnv, Ident, Value} 301 | eval {ident, funEnv, value_i} =^= 302 | let {ident', {funL, funE}, funEnv'} = lookupFun {ident, funEnv} 303 | Right(funL', sub_f) = evalRMatch {funL, value_i} 304 | {funE', funEnv'', value_o} = evalExp {funE, funEnv', sub_f} 305 | rlet {ident', {funL', funE'}, funEnv''} = lookupFun {ident'', funEnv'''} 306 | in {funEnv''', ident'', value_o} 307 | 308 | 309 | 310 | 311 | ------------------------------------------------------------------------------- 312 | -- ** Testing 313 | ------------------------------------------------------------------------------- 314 | 315 | --1 as ConstrV(S, [ConstrV(Z,[])]) 316 | testInc input =^= 317 | let {ident, funEnv} = inc 10 318 | value = fromValue input 319 | {funEnv', ident', value'} = eval {ident, funEnv, value} 320 | rlet {ident', funEnv'} = inc 10 321 | value' = fromValue output 322 | in output 323 | 324 | --inc Z =^= S(Z) 325 | --inc S(np) =^= 326 | -- let npp = inc np 327 | -- in S(npp) 328 | 329 | inc x =^= {x,[{10,{Var(1), 330 | CaseOf(Var(1), [ 331 | {Constr(Z,[]), LeftE(Constr(S, [Constr(Z,[])]))} 332 | , {Constr(S,[Var(2)]), LetIn(Var(3), 10, Var(2), LeftE(Constr(S, [Var(3)])))} 333 | ])}}]} 334 | 335 | testPlus input =^= 336 | let {ident, funEnv} = plus 11 337 | value = fromValue input 338 | {funEnv', ident', value'} = eval {ident, funEnv, value} 339 | rlet {ident', funEnv'} = plus 11 340 | value' = fromValue output 341 | in output 342 | 343 | testMinus input =^= 344 | let {ident, funEnv} = plus 12 345 | value = fromValue input 346 | {funEnv', ident', value'} = eval {ident, funEnv, value} 347 | rlet {ident', funEnv'} = plus 12 348 | value' = fromValue output 349 | in output 350 | 351 | --plus {x, Z } =^= |{x}| 352 | --plus {x,S(u)} =^= 353 | -- let {xp,up} = plus {x,u} 354 | -- in {xp, S(up)} 355 | 356 | plus x =^= {x,[{11,{ Constr(Tuple,[Var(10),Var(4)]), 357 | CaseOf(Var(4), [ 358 | {Constr(Z,[]), LeftE(DupEq(Constr(Tuple,[Var(10)])))} 359 | , {Constr(S,[Var(12)]), 360 | -- LeftE(Constr(Tuple,[Var(1),Var(3)])) 361 | LetIn(Constr(Tuple,[Var(4), Var(5)]), 11, Constr(Tuple,[Var(10),Var(12)]), 362 | LeftE(Constr(Tuple,[Var(4),Constr(S, [Var(5)])]))) 363 | } 364 | ]) 365 | }}, 366 | {1, {Var(1), RLetIn(Var(1), 11, Var(2), LeftE(Var(2)))} }]} 367 | 368 | 369 | fromValue Z =^= ConstrV(Z,[]) 370 | fromValue S(n) =^= 371 | let v = fromValue n 372 | in ConstrV(S, [v]) 373 | fromValue {x,y} =^= 374 | let x' = fromValue x 375 | y' = fromValue y 376 | in ConstrV(Tuple, [x',y']) 377 | fromValue {x} =^= 378 | let x' = fromValue x 379 | in ConstrV(Tuple, [x']) 380 | fromValue (x:xs) =^= 381 | let x' = fromValue x 382 | xs' = fromValue xs 383 | in ConstrV(Cons, [x',xs']) 384 | fromValue [] =^= ConstrV(Nil, []) 385 | 386 | 387 | 388 | 389 | 390 | 391 | -------------------------------------------------------------------------------- /core_examples/tm.rfun: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------- 2 | -- Implementation of Reversible Turing machine in RFUN 3 | ------------------------------------------------------------------------------- 4 | 5 | ------------------------------------------------------------------------------- 6 | -- ** For transition table 7 | ------------------------------------------------------------------------------- 8 | 9 | dupEq v =^= |v| 10 | dup v =^= |{v}| 11 | 12 | lookupH {e, ({l,d}:ls)} =^= 13 | case |{e,l}| of 14 | {e'} -> 15 | {{e', (Read:ls)}, d} 16 | {e',l'} -> 17 | let {{e', ls'}, r} = lookup {e',ls} 18 | in {{e', ({l',d}:ls')}, r} 19 | 20 | lookup {e, ls} =^= 21 | let {i', o} = lookupH {e, ls} 22 | {o',o''} = dup o 23 | rlet {i',o'} = lookupH {e', ls'} 24 | in {e', o'', ls'} 25 | 26 | 27 | readbackH {e, ({l,d}:ls)} =^= 28 | case |{e,d}| of 29 | {e'} -> 30 | {{e', (Read:ls)}, l} 31 | {e',d'} -> 32 | let {{e', ls'}, r} = lookup {e',ls} 33 | in {{e', ({l,d'}:ls')}, r} 34 | 35 | readback {e, d, ls} =^= 36 | let {i', o} = readbackH {e, ls} 37 | rlet {o , d} = dup o' 38 | {i',o'} = lookupH {e', ls'} 39 | in {e', ls'} 40 | 41 | ------------------------------------------------------------------------------- 42 | -- ** For tape operations 43 | ------------------------------------------------------------------------------- 44 | 45 | moveLeft {[], Blank, [] } =^= {[] , Blank, []} 46 | moveLeft {[], head, (right)} =^= {[], Blank, (head:right)} 47 | moveLeft {(l:left), Blank, [] } =^= {left, l, []} 48 | moveLeft {(l:left), head, (right)} =^= {left, l, (head:right)} 49 | 50 | move {Left, tape} =^= 51 | let tape = moveLeft tape' 52 | in {Left, tape'} 53 | move {Right, tape} =^= 54 | rlet tape = moveLeft tape' 55 | in {Right, tape'} 56 | move {Stay, tape} =^= 57 | {Stay, tape} 58 | 59 | ------------------------------------------------------------------------------- 60 | -- ** For tape operations 61 | ------------------------------------------------------------------------------- 62 | 63 | 64 | -- Transition table is a list of lists 65 | -- q1 s1 s2 q2 66 | -- 1 b b 2 67 | -- 2 / + 3 68 | -- 3 0 1 4 69 | -- 3 1 0 2 70 | -- 4 / - 5 71 | -- 5 b b 6 72 | -- 5 0 0 4 73 | 74 | binenc = [{1, Update({Blank, 2)}, 75 | {2, Move(Right, 3)}, -- 2 76 | {3, Update([{0,{1,4}},{1,{0,2}}])}, --3 77 | {4, Move(Left, 5)}, -- 4 78 | {5, Update([{0,{1,4}},{1,{0,2}}])} --5 79 | ] 80 | 81 | 82 | eval {state, tape, {move,}} =^= 83 | let {s', operation, t'} = lookup {state, transitions} 84 | 85 | perform {tape, Move(dir, newState)} =^= 86 | let {dir', tape'} = move {dir, tape} 87 | {s', s''} = dup newState 88 | in {tape', Move(dir', s'), s''} 89 | perform {{left, head, right}, Update(ls)} =^= 90 | let {head', {newSymb, newState}, ls'} = lookup {head, ls} 91 | 92 | updateHead {from, to, {left, head, right}} = 93 | rlet from' = dup {from, head} 94 | let {to', head'} = dup to 95 | in {from', to', {left, head', right}} 96 | 97 | procedure inst(int q,int pc, 98 | stack right,stack left, 99 | int q1,int s1,int s2,int q2) if q=q1[pc] then 100 | if s=s1[pc] then 101 | q += q2[pc]-q1[pc] s += s2[pc]-s1[pc] 102 | else 103 | if s1[pc]=SLASH then 104 | q += q2[pc]-q1[pc] if s2[pc]=RIGHT then 105 | // Move rule: 106 | // set q to q2[pc] 107 | call pushtape(s,left) 108 | uncall pushtape(s,right) else 109 | // push s on left // pop right to s 110 | uncall pushtape(s,left) fi s2[pc]=LEFT 111 | fi s2[pc]=RIGHT 112 | fi s1[pc]=SLASH 113 | fi s=s2[pc] 114 | fi q=q2[pc] 115 | -------------------------------------------------------------------------------- /core_examples/treeRank.rfun: -------------------------------------------------------------------------------- 1 | 2 | plus :: Nat -> Nat <-> Nat 3 | plus Z x = x 4 | plus S(y) x = 5 | let x' = plus y x 6 | in S(x') 7 | end 8 | 9 | mult :: Nat -> Nat <-> Nat 10 | mult x Z = Z 11 | --mult {x, S(Z) } =^= |{x}| 12 | mult x S(y) =^= 13 | let y' = mult x y 14 | in plus x y' 15 | end 16 | -------------------------------------------------------------------------------- /examples/basic.rfun: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------- 2 | ---- DUPLICATION / EQUALITY 3 | --------------------------------------------------------------- 4 | 5 | -- There exist a predefined data constuctor for 6 | -- equality-testing, which have the following definition. 7 | -- data EQ = Eq | Neq a 8 | 9 | -- Furthermore, there exist a predefined function to perform 10 | -- equality-testing. It is a special function with the 11 | -- following data type. 12 | -- eq :: a -> a <-> EQ 13 | 14 | -- Based on this we can define a duplication function 15 | dup :: a -> () <-> a 16 | dup x () = eq! x Eq 17 | 18 | --------------------------------------------------------------- 19 | ---- ARITHMETIC 20 | --------------------------------------------------------------- 21 | 22 | -- We can define the natural numbers as Peano numbers 23 | data Nat = Z | S Nat 24 | 25 | -- This will give the intuitive definition of addition 26 | plus :: Nat -> Nat <-> Nat 27 | plus Z x = x 28 | plus (S y) x = 29 | let x' = plus y x 30 | in (S x') 31 | 32 | minus :: Nat -> Nat <-> Nat 33 | minus y x = plus! y x 34 | 35 | 36 | mult :: Nat -> Nat <-> Nat 37 | mult x Z = Z 38 | mult x (S y) = 39 | let m = mult x y 40 | in plus x m 41 | 42 | -- binom :: Nat -> Nat <-> Nat 43 | -- binom n Z = (S Z) 44 | -- binom n (S k) = 45 | -- let r = binom 46 | 47 | data Bool = True | False 48 | 49 | even :: Nat -> () <-> Bool 50 | even 0 () = True 51 | even 1 () = False 52 | even (S y) () = 53 | let b = even y () 54 | in not b 55 | 56 | not :: Bool <-> Bool 57 | not True = False 58 | not False = True 59 | 60 | 61 | map :: (a <-> b) -> [a] <-> [b] 62 | map fun [] = [] 63 | map fun (l:ls) = 64 | let l' = fun l 65 | ls' = map fun ls 66 | in (l':ls') 67 | 68 | -- Equal to the Haskell tails function 69 | tails :: [a] <-> [[a]] 70 | tails [] = [[]] 71 | tails (x:xs) = 72 | let xs' = dup xs () 73 | ys = tails xs 74 | in ((x:xs'):ys) 75 | 76 | scanl1 :: (a -> a <-> a) -> [a] <-> [a] 77 | scanl1 fun [] = [] 78 | scanl1 fun [x] = [x] 79 | scanl1 fun (x:y:ls) = 80 | let y' = fun x y 81 | ls' = scanl1 fun (y':ls) 82 | in (x:ls') 83 | 84 | scanr1 :: (a -> a <-> a) -> [a] <-> [a] 85 | scanr1 fun [] = [] 86 | scanr1 fun [x] =[x] 87 | scanr1 fun (x:y:ls) = 88 | let (y':ls') = scanr1 fun (y:ls) 89 | x' = fun y' x 90 | in (x':y':ls') 91 | 92 | 93 | --------------------------------------------------------------- 94 | ---- APPLICATIONS 95 | --------------------------------------------------------------- 96 | 97 | data Tree = Leaf Nat | Node Nat Tree Tree 98 | 99 | --------------------------------------------------------------- 100 | ---- APPLICATIONS 101 | --------------------------------------------------------------- 102 | 103 | -- The classical Fibonacci function (embedded to result in a 104 | -- pair) can be defined in the following way. 105 | fib :: Nat <-> (Nat, Nat) 106 | fib Z = ((S Z),Z) 107 | fib (S m) = 108 | let (x,y) = fib m 109 | y' = plus x y 110 | in (y', x) 111 | 112 | -- The implementation of a run-length encoding function 113 | -- using the equality function 114 | pack :: [a] <-> [(a, Nat)] 115 | pack [] = [] 116 | pack (c1 : r) = 117 | case (pack r) of 118 | [] -> [(c1, 1)] 119 | ((c2, n) : t) -> 120 | case (eq c1 c2) of 121 | (Neq c2p) -> ((c1, 1) : (c2p, n) : t) 122 | (Eq) -> ((c1, (S n)) : t) 123 | 124 | -- Identical to Haskell group function 125 | -- and not far from the run-length encoding 126 | group :: [a] <-> [[a]] 127 | group [] = [] 128 | group (x:xs) = 129 | case (group xs) of 130 | [] -> [[x]] 131 | ((y:ys):tail) -> 132 | case (eq x y) of 133 | (Eq) -> 134 | let y' = dup x () 135 | in ((x:y:ys):tail) 136 | (Neq y') -> ([x]:(y':ys):tail) 137 | -------------------------------------------------------------------------------- /mkdocs.yml: -------------------------------------------------------------------------------- 1 | site_name: RFun 2 | -------------------------------------------------------------------------------- /rfun-interp.cabal: -------------------------------------------------------------------------------- 1 | -- Initial rfun-interp.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: rfun-interp 5 | version: 0.1.0.0 6 | synopsis: Interpreter for the reversible functional language rFun 7 | -- description: 8 | license: AllRightsReserved 9 | license-file: LICENSE 10 | author: Michael Kirkedal Thomsen 11 | maintainer: kirkedal@acm.org 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | 17 | library 18 | -- exposed-modules: 19 | -- other-modules: 20 | build-depends: base ==4.6.* 21 | hs-source-dirs: src -------------------------------------------------------------------------------- /src/Ast.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Ast 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Abstract syntax tree for RFun17 12 | -- 13 | -- The language is based on, to which the are make references in the comments: 14 | -- 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Ast where 19 | 20 | import qualified Text.Megaparsec as P -- (SourcePos, SourcePos(..), Pos(..)) 21 | import qualified Data.Map as M 22 | 23 | import Data.Complex 24 | 25 | -- data Module = Module { moduleName :: Ident 26 | -- , moduleExports :: [Ident] 27 | -- , moduleImports :: [Ident] 28 | -- , moduleProgram :: Program} 29 | -- deriving (Eq, Show) 30 | -- -- |A program is a sequence of functions 31 | 32 | type Program = [Func] 33 | 34 | -- |A function is an identifier is some left-expression as parameter and 35 | -- an expression as body 36 | data Func = Func { funcName :: Ident 37 | , funcTypesig :: Maybe TypeSig 38 | , funcClause :: [Clause] } 39 | | DataType { dataName :: Ident 40 | , dataDef :: M.Map String (Ident, [BType]) } 41 | deriving (Eq, Show) 42 | 43 | data Clause = Clause { clauseIdent :: Ident 44 | , clauseParam :: [LExpr] 45 | , clauseGuard :: Guard 46 | , clauseBody :: Expr } 47 | deriving (Eq, Show) 48 | 49 | data TypeSig = TypeSig [BType] BType BType 50 | deriving (Eq, Show) 51 | 52 | data BType = IntT | QbitT | DataT Ident | ListT BType | ProdT [BType] | SumT [BType] | FunT TypeSig | VarT Ident | AnyT 53 | deriving (Eq, Show) 54 | 55 | -- |An expression is 56 | data Expr = LeftE LExpr -- ^ Left-expression 57 | | LetIn LExpr LExpr Expr -- ^ Let-binding 58 | | CaseOf LExpr [(LExpr, Guard, Expr)] -- ^ Case-of expression 59 | deriving (Show, Eq) 60 | 61 | data Guard = Guard [LExpr] 62 | deriving (Eq, Show) 63 | 64 | -- |A left-expression is 65 | data LExpr = Var Ident -- ^ Variable 66 | | Constr Ident [LExpr] -- ^ Constructor term 67 | | Int Integer 68 | | Tuple [LExpr] -- ^ Constructor term 69 | | List LExprList 70 | | App Ident Bool [LExpr] 71 | deriving (Show, Eq) 72 | 73 | data LExprList = ListCons LExpr LExprList 74 | | ListEnd LExpr 75 | | ListNil 76 | deriving (Show, Eq) 77 | 78 | -- |Identifiers at simple Strings 79 | data Ident = Ident { identifier :: String 80 | , sourcePos :: P.SourcePos } 81 | deriving (Eq, Show) 82 | 83 | -- |A value (p. 16) is defined as 84 | -- * a constructor of 0 or more values 85 | data Value = IntV Integer 86 | | QbitV (Complex Double) 87 | | TupleV [Value] 88 | | ListV [Value] 89 | | ConstrV String [Value] 90 | | FunV String 91 | deriving (Show, Eq) 92 | 93 | 94 | 95 | type FuncEnv = M.Map String Func 96 | 97 | makeFunEnv :: Program -> FuncEnv 98 | makeFunEnv p = M.fromList $ map (\x -> ((identifier. funcName) x, x)) p 99 | 100 | makeIdent :: String -> Ident 101 | makeIdent s = Ident s (P.SourcePos "" (P.unsafePos 1) (P.unsafePos 1)) -------------------------------------------------------------------------------- /src/Core/Ast.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Ast 4 | -- Copyright : Michael Kirkedal Thomsen, 2013 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Abstract syntax tree for RFun 12 | -- 13 | -- The language is based on, to which the are make references in the comments: 14 | -- 15 | -- Grammar: 16 | -- q ::= d* (program) 17 | -- d ::= f l =^= e (definition) 18 | -- l ::= x (variable) 19 | -- | c(l_1,...,l_n) (constructor) 20 | -- | |l| (duplication/equality) 21 | -- e ::= l (left-expression) 22 | -- | let l_out = f l_in in e (let-expression) 23 | -- | rlet l_in = f l_out in e (rlet-expression) 24 | -- | case l of {l_i -> e_i}+ (case-expression) 25 | -- 26 | -- Syntax domains: 27 | -- q ∈ Programs 28 | -- d ∈ Definitions 29 | -- f ∈ Functions 30 | -- l ∈ Left-expressions 31 | -- e ∈ Expressions 32 | -- x ∈ Variables 33 | -- c ∈ Constructors 34 | -- 35 | -- Abstract syntax of the first-order functional language (n ≥ 0, m ≥ 1) The Language 36 | -- 37 | ----------------------------------------------------------------------------- 38 | 39 | module Core.Ast where 40 | 41 | import qualified Data.Map as M 42 | import Data.List (intercalate) 43 | 44 | -- |A program is a sequence of functions 45 | type Program = [Func] 46 | 47 | -- |A function is an identifier is some left-expression as parameter and 48 | -- an expression as body 49 | data Func = Func { funcname :: Ident 50 | , param :: LExpr 51 | , body :: Expr } 52 | deriving (Eq, Show) 53 | 54 | -- |An expression is 55 | data Expr = LeftE LExpr -- ^ Left-expression 56 | | LetIn LExpr Ident LExpr Expr -- ^ Let-binding 57 | | RLetIn LExpr Ident LExpr Expr -- ^ Let-binding with reverse function call 58 | | CaseOf LExpr [(LExpr, Expr)] -- ^ Case-of expression 59 | deriving (Show, Eq) 60 | 61 | -- |A left-expression is 62 | data LExpr = Var Ident -- ^ Variable 63 | | Constr Ident [LExpr] -- ^ Constructor term 64 | | DupEq LExpr -- ^ Duplication / equality test 65 | deriving (Show, Eq) 66 | 67 | -- |Identifiers at simple Strings 68 | type Ident = String 69 | 70 | 71 | -- |A value (p. 16) is defined as 72 | -- * a constructor of 0 or more values 73 | data Value = ConstrV Ident [Value] 74 | deriving (Show, Eq) 75 | 76 | -- |Converting a value to a left-expression 77 | valueToLExpr :: Value -> LExpr 78 | valueToLExpr (ConstrV ident values) = 79 | Constr ident (map valueToLExpr values) 80 | 81 | constrToNum :: LExpr -> Maybe Int 82 | constrToNum (Constr "Z" []) = Just 0 83 | constrToNum (Constr "S" [lExpr]) = do n <- constrToNum lExpr ; Just $ n + 1 84 | constrToNum (Constr "P" [lExpr]) = do n <- constrToNum lExpr ; Just $ n - 1 85 | constrToNum _c = Nothing 86 | 87 | 88 | -- |Function environments (to be used later) is a mapping from Identifiers to a Function 89 | type FuncEnv = M.Map Ident Func 90 | 91 | prettyFuncEnv :: FuncEnv -> String 92 | prettyFuncEnv funcEnv = 93 | intercalate "\n" $ map (pretty.snd) $ M.toList funcEnv 94 | 95 | -- |Pretty for showing programs and values 96 | class Pretty a where 97 | pretty :: a -> String 98 | 99 | instance Pretty Func where 100 | pretty (Func funname funparam funbody) = funname ++ " " ++ pretty funparam ++ " =^= \n" ++ pretty funbody 101 | 102 | instance Pretty LExpr where 103 | pretty (Var ident) = ident 104 | pretty (Constr "Z" []) = "0" 105 | pretty c@(Constr "S" lExprs) = 106 | case constrToNum c of 107 | Just n -> show n 108 | Nothing -> "S(" ++ (intercalate ", " $ map pretty lExprs) ++ ")" 109 | pretty c@(Constr "P" lExprs) = 110 | case constrToNum c of 111 | Just n -> show n 112 | Nothing -> "P(" ++ (intercalate ", " $ map pretty lExprs) ++ ")" 113 | pretty (Constr "Cons" [lExpr1,lExpr2]) = 114 | case getList lExpr2 of 115 | Just(val) -> "[" ++ (intercalate ", " $ map pretty (lExpr1 : val)) ++ "]" 116 | Nothing -> "(" ++ pretty lExpr1 ++ " : " ++ pretty lExpr2 ++ ")" 117 | pretty (Constr "Nil" []) = "[ ]" 118 | pretty (Constr "Tuple" lExprs) = "{" ++ (intercalate ", " $ map pretty lExprs) ++ "}" 119 | pretty (Constr eIdent []) = eIdent 120 | pretty (Constr eIdent lExprs) = eIdent ++ "(" ++ (intercalate ", " $ map pretty lExprs) ++ ")" 121 | pretty (DupEq lExpr) = "|" ++ pretty lExpr ++ "|" 122 | 123 | instance Pretty Expr where 124 | pretty (LeftE lExpr) = pretty lExpr 125 | pretty (LetIn lExpr_out ident lExpr_in expr) = 126 | "let " ++ pretty lExpr_out ++ " = " ++ ident ++ " " ++ pretty lExpr_in ++ "\n in " ++ pretty expr ++ "\n" 127 | pretty (RLetIn lExpr_in ident lExpr_out expr) = 128 | "rlet " ++ pretty lExpr_in ++ " = " ++ ident ++ " " ++ pretty lExpr_out ++ "\n in " ++ pretty expr ++ "\n" 129 | pretty (CaseOf lExpr matches) = 130 | "case " ++ pretty lExpr ++ " of " ++ "{\n" ++ intercalate "\n" (map (\(le,e) -> pretty le ++ " -> " ++ pretty e) matches) ++ "}" 131 | 132 | getList :: LExpr -> Maybe [LExpr] 133 | getList (Constr "Nil" []) = Just([]) 134 | getList (Constr "Cons" [lExpr1,lExpr2]) = 135 | do v <- getList lExpr2 136 | return $ lExpr1 : v 137 | getList _ = Nothing 138 | 139 | instance Pretty Value where 140 | pretty value = pretty $ valueToLExpr value 141 | 142 | -------------------------------------------------------------------------------- /src/Core/Interp.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Interp 4 | -- Copyright : Michael Kirkedal Thomsen, 2013 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Implementation an interpreter for RFun 12 | -- 13 | -- The design is intended to follow closely* the design of the RFun paper: 14 | -- 15 | -- T. Yokoyama, H. B. Axelsen, and R. Gluck 16 | -- Towards a reversible functional language 17 | -- LNCS vol. 7165, pp. 14--29, 2012 18 | -- 19 | -- * I know that there are an obvious reader monad below. 20 | ----------------------------------------------------------------------------- 21 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 22 | 23 | module Core.Interp where 24 | 25 | import Core.Ast 26 | import qualified Data.Map as M 27 | import Control.Monad 28 | import Control.Monad.Writer 29 | import Control.Monad.Except 30 | -- import Debug.Trace (trace) 31 | 32 | ------------------------------------------------------------------------------- 33 | -- * Interpreter main 34 | ------------------------------------------------------------------------------- 35 | 36 | -- |Evaluating with return either a result of an ErrorRFun 37 | type EvalTrace = [String] 38 | 39 | -- |An error is a String 40 | type ErrorRFun = String 41 | -- data ErrorRFun = PatternMatching 42 | -- | WrongEQ 43 | 44 | newtype Eval a = E { runE :: WriterT EvalTrace (Either ErrorRFun) a } 45 | deriving (Applicative, Functor, Monad, MonadWriter EvalTrace, MonadError ErrorRFun) 46 | 47 | runEval :: Eval a -> Either ErrorRFun (a, EvalTrace) 48 | runEval eval = runWriterT (runE eval) 49 | 50 | -- |Making an Maybe an Eval 51 | evalMaybe :: ErrorRFun -> Maybe a -> Eval a 52 | evalMaybe e Nothing = failEval e 53 | evalMaybe _ (Just a) = return a 54 | 55 | -- |Simple fail 56 | failEval :: ErrorRFun -> Eval a 57 | failEval e = 58 | throwError e 59 | 60 | -- |Interpreting an rFun program 61 | runProg :: Ident -> Value -> FuncEnv -> Either ErrorRFun (Value, EvalTrace) 62 | runProg ident value funcEnv = 63 | runEval $ evalFunV funcEnv idSub idSub ident (valueToLExpr value) 64 | 65 | ------------------------------------------------------------------------------- 66 | -- ** Substitutions and functions on these 67 | ------------------------------------------------------------------------------- 68 | -- |A substitution is a mapping from a Ident (string) to a value 69 | type Substitution = M.Map Ident Value 70 | 71 | -- |Make a empty substitution 72 | idSub :: Substitution 73 | idSub = M.empty 74 | 75 | -- |Make a substitution of one variable 76 | newSub :: Ident -> Value -> Substitution 77 | newSub ident value = M.singleton ident value 78 | 79 | -- |Lookup a value in a substitution without any limitations -- used in function lookup 80 | peakValue :: Ident -> Substitution -> Maybe Value 81 | peakValue ident sub = M.lookup ident sub 82 | 83 | -- |Lookup a value in a substitution 84 | lookupValue :: Ident -> Substitution -> Eval Value 85 | lookupValue ident sub 86 | | M.size sub == 1 = evalMaybe ("Variable "++ ident ++" not found") $ M.lookup ident sub 87 | | otherwise = failEval "Substitution is not singleton" 88 | 89 | -- |Divides a substitution into two. First part contains the mappings contained 90 | -- in the list of Idents, the second the rest. 91 | divide :: [Ident] -> Substitution -> Eval (Substitution, Substitution) 92 | divide idents sub = 93 | if M.size sub1enc == length idents 94 | then return (sub1enc, sub2) 95 | else failEval $ "Variables not found when dividing:\n\t" ++ show idents ++ "\n" ++ show sub1 96 | where 97 | (sub1, sub2) = M.partitionWithKey (\k _ -> elem k idents) sub 98 | sub1enc = M.fromList $ map (identAdd sub1) idents 99 | identAdd subA i = 100 | case peakValue i subA of 101 | Nothing -> (i, ConstrV i []) 102 | Just v -> (i, v) 103 | 104 | -- |Lookup a value in a substitution. Returns the value of the identifier and 105 | -- the substitution with the identifier removed. 106 | lookupDivide :: Ident -> Substitution -> Eval (Value, Substitution) 107 | lookupDivide ident sub = 108 | do 109 | (singleton, rest) <- divide [ident] sub 110 | value <- lookupValue ident singleton 111 | return (value, rest) 112 | 113 | -- |Finds the disjoint union between two substitutions 114 | disUnion :: Substitution -> Substitution -> Eval Substitution 115 | disUnion subs1 subs2 = 116 | if union_size == subs1_size + subs2_size 117 | then return union12 118 | else failEval "Substitutions are not disjoint" 119 | where 120 | union12 = M.union subs1 subs2 121 | union_size = M.size union12 122 | subs1_size = M.size subs1 123 | subs2_size = M.size subs2 124 | 125 | -- |Finds the union between two disjoint substitutions (no overlap in idents). 126 | disjointUnion_M :: Eval Substitution -> Eval Substitution -> Eval Substitution 127 | disjointUnion_M subs1 subs2 = join $ liftM2 disUnion subs1 subs2 128 | 129 | -- |Finds the union between a list of disjoint substitutions. 130 | disjointUnions_M :: [Eval Substitution] -> Eval Substitution 131 | disjointUnions_M subs = foldl disjointUnion_M (return idSub) subs 132 | 133 | 134 | ------------------------------------------------------------------------------- 135 | -- ** Program functions 136 | ------------------------------------------------------------------------------- 137 | 138 | -- |Lookup a function in the function environment 139 | lookupFunction :: FuncEnv -> Ident -> Eval (LExpr, Expr) 140 | lookupFunction funcEnv ident = 141 | case M.lookup ident funcEnv of 142 | Just(func) -> return (param func, body func) 143 | Nothing -> failEval ("Function "++ ident ++" not found") 144 | 145 | 146 | ------------------------------------------------------------------------------- 147 | -- ** The interpreter 148 | ------------------------------------------------------------------------------- 149 | 150 | -- |Eq/Dup operator (Eqs. 3 and 4, p. 17) 151 | evalDupEq :: Value -> Eval Value 152 | -- Unary tuple is copied 153 | evalDupEq (ConstrV "Tuple" [value]) = return $ ConstrV "Tuple" [value,value] 154 | -- Binary tuple becomes a unary if values are equal, otherwise unchanged 155 | evalDupEq c@(ConstrV "Tuple" [value1,value2]) 156 | | value1 == value2 = return $ ConstrV "Tuple" [value1] 157 | | otherwise = return $ c 158 | evalDupEq _ = failEval "Value is not a unary or binary tuple" 159 | 160 | -- |R-Match (Fig. 2, p. 18) that returns a substitution. 161 | -- Returns a substitution 162 | evalRMatchS :: Value -> LExpr -> Eval Substitution 163 | --evalRMatchS value lExpr | trace ("evalRMatchV " ++ pretty lExpr) False = undefined 164 | -- Single variable resulting in a singleton substitution 165 | evalRMatchS value (Var ident) = return $ newSub ident value 166 | -- Constructor or a special constructor 167 | evalRMatchS v@(ConstrV vIdent values) le@(Constr eIdent lExprs) = 168 | if ((length values) == (length lExprs)) && (vIdent == eIdent) 169 | then disjointUnions_M $ zipWith evalRMatchS values lExprs 170 | else failEval $ "Different constructors of value\n\t" ++ pretty v ++ "\nand pattern\n\t" ++ pretty le 171 | -- Dublication / Equality 172 | evalRMatchS value (DupEq lExpr) = do 173 | dupEq <- evalDupEq value 174 | evalRMatchS dupEq lExpr 175 | 176 | -- |R-Match (Fig. 2, p. 18) that returns a value 177 | evalRMatchV :: Substitution -> LExpr -> Eval Value 178 | --evalRMatchV sub lExpr | trace ("evalRMatchV " ++ pretty lExpr) False = undefined 179 | -- Single variable resulting in a single value 180 | evalRMatchV sub (Var ident) = lookupValue ident sub 181 | -- Constructor or a special constructor 182 | evalRMatchV sub (Constr eIdent lExprs) = 183 | do 184 | vals <- zipWithM (flip evalRMatchV) lExprs =<< subsf 185 | return $ ConstrV eIdent vals 186 | where 187 | vars = map findVars lExprs 188 | subs = mapM (flip divide $ sub) vars 189 | subsf = liftM (map fst) subs 190 | -- Not sure that this makes sense 191 | evalRMatchV sub (DupEq lExpr) = evalDupEq =<< evalRMatchV sub lExpr 192 | 193 | 194 | -- |Function calls: Fig 3, p. 19, FunExp 195 | -- Function calls in a sub part of lets 196 | evalFunS :: FuncEnv -> Substitution -> Ident -> LExpr -> Value -> Eval Substitution 197 | --evalFunS _ ident lExpr value | trace ("--------------\nevalFunS: " ++ ident ++ "\n Value = " ++ pretty value ++ "\n LExpr: " ++ pretty lExpr) False = undefined 198 | --evalFunS _ ident lExpr value | trace ("evalFunS: " ++ ident) False = undefined 199 | evalFunS funcEnv peakSub ident lExpr value = 200 | do 201 | (lExprFun, exprFun) <- lookupFunction funcEnv =<< lident 202 | sub_f <- evalExpS funcEnv exprFun value 203 | val_p <- evalRMatchV sub_f lExprFun 204 | evalExpS funcEnv (LeftE lExpr) val_p 205 | where 206 | lident = 207 | case peakValue ident peakSub of 208 | Nothing -> return ident 209 | (Just (ConstrV i [])) -> return i 210 | _ -> failEval "Values is not a function name" 211 | 212 | -- |Function calls that returns a value 213 | evalFunV :: FuncEnv -> Substitution -> Substitution -> Ident -> LExpr -> Eval Value 214 | --evalFunV _ _ ident lExpr | trace ("evalFunV: " ++ ident ++ " (...) = ") False = undefined 215 | --evalFunV _ sub ident lExpr | trace ("--------------\nevalFunV: " ++ ident ++ "\n Subst: [" ++ (intercalate "," $ map (\(x,y) -> "("++show x++","++pretty y++")") $ M.toList sub ) ++ "]\n LExpr: " ++ pretty lExpr) False = undefined 216 | evalFunV funcEnv peakSub sub ident lExpr = 217 | do 218 | (lExprFun, exprFun) <- lookupFunction funcEnv =<< lident 219 | val_p <- evalExpV funcEnv sub (LeftE lExpr) 220 | sub_f <- evalRMatchS val_p lExprFun 221 | evalExpV funcEnv sub_f exprFun 222 | where 223 | lident = 224 | case peakValue ident peakSub of 225 | Nothing -> return ident 226 | (Just (ConstrV i [])) -> return i 227 | _ -> failEval "Values is not a function name" 228 | 229 | -- |Expressions: Fig 3, p. 19 (not FunExp) that returns substitution 230 | evalExpS :: FuncEnv -> Expr -> Value -> Eval Substitution 231 | evalExpS _ (LeftE lExpr) value = evalRMatchS value lExpr 232 | evalExpS funcEnv (LetIn lExpr_out ident lExpr_in expr) value = 233 | do 234 | sub_end <- evalExpS funcEnv expr value 235 | (sub_out, sub_e) <- divide vars sub_end 236 | val_out <- evalRMatchV sub_out lExpr_out 237 | sub_in <- evalFunS funcEnv sub_e ident lExpr_in val_out 238 | disUnion sub_in sub_e 239 | where 240 | vars = findVars lExpr_out 241 | evalExpS funcEnv (RLetIn lExpr_in ident lExpr_out expr) value = 242 | do 243 | sub_end <- evalExpS funcEnv expr value 244 | (sub_out, sub_e) <- divide vars sub_end 245 | val_in <- evalFunV funcEnv sub_e sub_out ident lExpr_out 246 | sub_in <- evalRMatchS val_in lExpr_in 247 | disUnion sub_in sub_e 248 | where 249 | vars = findVars lExpr_out 250 | evalExpS funcEnv e@(CaseOf lExpr matches) value = 251 | do 252 | (j, _) <- evalMaybe ("No match in leaves of cases:\n\t" ++ pretty e ++ "\nof value:\n\t" ++ pretty value) $ 253 | findSubIndex (evalRMatchS value) $ concatMap (\(x,y) -> zip (repeat x) y) allLeaves 254 | sub_jt <- evalExpS funcEnv (snd $ matches !! j) value 255 | let lExpr_j = fst $ matches !! j 256 | vars_j = findVars lExpr_j 257 | (sub_j, sub_t) <- divide vars_j sub_jt 258 | val_p <- evalRMatchV sub_j lExpr_j 259 | sub_l <- evalExpS funcEnv (LeftE lExpr) val_p 260 | sub_lt <- disUnion sub_l sub_t 261 | -- A consistency check with val_p against previous l in cases 262 | let takenMatches = take j matches 263 | takenLExpr = map fst takenMatches 264 | evalMaybe ("Return value match in preceding leaves: (" ++ show j ++ ")\n\t" ++ pretty val_p ++ "\nin expression:\n\t" ++ pretty e) $ 265 | checkLExprs evalRMatchS val_p sub_lt takenLExpr 266 | where 267 | allLeaves = zip [0..] $ map (leaves.snd) matches 268 | 269 | -- |Expressions: Fig 3, p. 19 (not FunExp) that returns value 270 | evalExpV :: FuncEnv -> Substitution -> Expr -> Eval Value 271 | evalExpV _ sub (LeftE lExpr) = evalRMatchV sub lExpr 272 | evalExpV funcEnv sub (LetIn lExpr_out ident lExpr_in expr) = 273 | do 274 | (sub_in, sub_e) <- divide vars sub 275 | val_out <- evalFunV funcEnv sub_e sub_in ident lExpr_in 276 | sub_out <- evalRMatchS val_out lExpr_out 277 | sub_end <- disUnion sub_out sub_e 278 | evalExpV funcEnv sub_end expr 279 | where 280 | vars = findVars lExpr_in 281 | evalExpV funcEnv sub (RLetIn lExpr_in ident lExpr_out expr) = 282 | do 283 | (sub_in, sub_e) <- divide vars sub 284 | val_in <- evalRMatchV sub_in lExpr_in 285 | sub_out <- evalFunS funcEnv sub_e ident lExpr_out val_in 286 | sub_end <- disUnion sub_out sub_e 287 | evalExpV funcEnv sub_end expr 288 | where 289 | vars = findVars lExpr_in 290 | evalExpV funcEnv sub e@(CaseOf lExpr matches) = 291 | do 292 | (sub_l, sub_t) <- divide vars sub 293 | val_p <- evalExpV funcEnv sub_l (LeftE lExpr) 294 | (j, sub_j) <- evalMaybe ("No match in cases:\n\t" ++ pretty e ++ "\nof value:\n\t" ++ pretty val_p) $ 295 | findSubIndex (evalRMatchS val_p) $ zip ([0..]) (map fst matches) 296 | sub_jt <- disUnion sub_j sub_t 297 | val <- evalExpV funcEnv sub_jt $ snd $ matches !! j 298 | -- A consistency check with val against previous l in cases 299 | let takenMatches = take j matches 300 | takenExpr = map snd takenMatches 301 | leaves_j = concatMap leaves takenExpr 302 | evalMaybe ("Return value match in preceding leaves:\n\t" ++ pretty val ++ "\nin expression:\n\t" ++ pretty e) $ 303 | checkLeaves evalRMatchS val leaves_j 304 | where 305 | vars = findVars lExpr 306 | 307 | -- |This function is helper for the caseOf 308 | checkLeaves :: (Value -> LExpr -> Eval c) -> Value -> [LExpr] -> Maybe Value 309 | checkLeaves _ val [] = return (val) 310 | checkLeaves func val (l:list) = 311 | either (\_ -> checkLeaves func val list) (\_ -> Nothing) (runEval $ func val l) 312 | 313 | -- |This function is helper for the caseOf 314 | checkLExprs :: (Value -> LExpr -> Eval c) -> Value -> Substitution -> [LExpr] -> Maybe Substitution 315 | checkLExprs _ _ sub [] = return (sub) 316 | checkLExprs func val sub (l:list) = 317 | either (\_ -> checkLExprs func val sub list) (\_ -> Nothing) (runEval $ func val l) 318 | 319 | -- | Finds the minimum index of a case-leave to which a eval-function matches. 320 | -- The list is indexed from 0; different from the paper!!!! 321 | findSubIndex :: (a -> Eval b) -> [(Int,a)] -> Maybe (Int, b) 322 | findSubIndex func list = 323 | findSubIndex_h func list 324 | where 325 | findSubIndex_h _ [] = Nothing 326 | findSubIndex_h f (l:ls) = 327 | -- (return $ (fst l,(f $ snd l))) `catchError` (\_ -> (findSubIndex_h f ls)) 328 | either (\_ -> (findSubIndex_h f ls)) (\r -> return (fst l, fst r)) (runEval $ f $ snd l) 329 | 330 | -- |As defined in Footnote 1, p 19. 331 | leaves :: Expr -> [LExpr] 332 | leaves (LeftE lExpr) = [lExpr] 333 | leaves (LetIn _ _ _ expr) = leaves expr 334 | leaves (RLetIn _ _ _ expr) = leaves expr 335 | leaves (CaseOf _ matches) = concatMap (leaves . snd) matches 336 | 337 | -- |Finds the list of all variables in a left expression 338 | findVars :: LExpr -> [Ident] 339 | findVars (Var ident) = [ident] 340 | findVars (Constr _ lExprs) = concatMap findVars lExprs 341 | findVars (DupEq lExpr) = findVars lExpr 342 | 343 | -------------------------------------------------------------------------------- /src/Core/Parser.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Parser 4 | -- Copyright : Michael Kirkedal Thomsen, 2013 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Implementation a simple parser for rFun 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | 16 | module Core.Parser (parseString, parseFromFile, parseValue, ParseError) where 17 | 18 | 19 | import Text.ParserCombinators.Parsec hiding (parse,parseFromFile) 20 | import qualified Text.Parsec.Token as P 21 | import Text.Parsec.Prim (runP) 22 | import Control.Monad.Identity 23 | 24 | import Core.Ast 25 | 26 | type ParserState = [String] 27 | 28 | initialState :: ParserState 29 | initialState = [] 30 | type LangParser = GenParser Char ParserState 31 | 32 | ------------------------------------------------------------------------------- 33 | -- * Functions for parsing values and programs 34 | ------------------------------------------------------------------------------- 35 | 36 | --parse' p = parse p "could not parse" 37 | parse :: LangParser a -> String -> String -> Either ParseError a 38 | parse p = runP p initialState 39 | 40 | -- |Parse a RFun program from a file 41 | parseFromFile :: String -> IO (Either ParseError Program) 42 | parseFromFile fname 43 | = do input <- readFile fname 44 | return (parse program fname input) 45 | 46 | -- |Parse a RFun program from a string 47 | parseString :: String -> IO (Either ParseError Program) 48 | parseString input = return $ parse program "Text field" input 49 | 50 | -- |Parse a RFun value from a string 51 | parseValue :: String -> IO (Either ParseError Value) 52 | parseValue input = return $ parse value "Value" input 53 | 54 | ------------------------------------------------------------------------------- 55 | -- * Implementation of the parser 56 | ------------------------------------------------------------------------------- 57 | 58 | cStyle :: P.GenLanguageDef String st Identity 59 | cStyle = P.LanguageDef { 60 | P.commentStart = "", 61 | P.commentEnd = "", 62 | P.commentLine = "--", 63 | P.nestedComments = False, 64 | P.identStart = letter <|> char '_', 65 | P.identLetter = alphaNum <|> char '_' <|> char '\'', 66 | P.opStart = oneOf "=-|", 67 | P.opLetter = oneOf "^=>|-", 68 | P.reservedOpNames = ["=^=", "=", "->", "#"], 69 | P.reservedNames = ["let", "rlet", "in", "case", "of"], 70 | P.caseSensitive = True 71 | } 72 | 73 | -- |Used to conveniently create the parsers 'natural', 'constant', and 'identifier' 74 | lexer :: P.GenTokenParser String u Identity 75 | lexer = P.makeTokenParser cStyle 76 | 77 | -- |Parses a natural number 78 | natural :: CharParser st Integer 79 | natural = P.natural lexer 80 | 81 | lexeme :: CharParser st a -> CharParser st a 82 | lexeme = P.lexeme lexer 83 | 84 | -- |Parses white space 85 | whiteSpace :: CharParser st () 86 | whiteSpace = P.whiteSpace lexer 87 | 88 | -- |Parses the string s and skips trailing whitespaces 89 | symbol :: String -> CharParser st String 90 | symbol = P.symbol lexer 91 | 92 | -- |Parses and returns a valid identifier 93 | identifier :: CharParser st String 94 | identifier = P.identifier lexer 95 | 96 | -- |Parser @(parens p)@ parses p and trailing whitespaces enclosed in parenthesis ('(' and ')'), 97 | -- returning the value of p. 98 | parens :: CharParser st a -> CharParser st a 99 | parens = P.parens lexer 100 | 101 | -- |Parser @(brackets p)@ parses p and trailing whitespaces enclosed in square brackets ('[' and ']'), 102 | -- returning the value of p. 103 | brackets :: CharParser st a -> CharParser st a 104 | brackets = P.squares lexer 105 | 106 | -- |Parser @(brackets p)@ parses p and trailing whitespaces enclosed in square brackets ('{' and '}'), 107 | -- returning the value of p. 108 | braces :: CharParser st a -> CharParser st a 109 | braces = P.braces lexer 110 | 111 | reserved :: String -> CharParser st () 112 | reserved = P.reserved lexer 113 | 114 | -- |Parses a constant (i.e. a number) 115 | -- 116 | -- Looks kinda useless but the definition of constant is not fixed 117 | constant :: CharParser st Int 118 | constant = lexeme natural >>= return . fromIntegral 119 | 120 | --eol = string "\n" 121 | 122 | program :: LangParser Program 123 | program = 124 | do whiteSpace 125 | f <- many1 funDef 126 | return f 127 | 128 | funDef :: LangParser Func 129 | funDef = do i <- identifier 130 | le <- lexpr 131 | symbol "=^=" 132 | e <- expr 133 | return $ Func i le e 134 | 135 | expr :: LangParser Expr 136 | expr = try letin <|> try rletin <|> try caseofF <|> try caseof <|> try apply <|> lefte 137 | where 138 | letin = do reserved "let" 139 | l <- many1 assign 140 | e <- choice [inPart, letin, rletin] 141 | return $ foldr (\(lExpr1, ident, lExpr2) ex -> LetIn lExpr1 ident lExpr2 ex) e l 142 | rletin = do reserved "rlet" 143 | l <- many1 assign 144 | e <- choice [inPart, letin, rletin] 145 | return $ foldr (\(lExpr1, ident, lExpr2) ex -> RLetIn lExpr1 ident lExpr2 ex) e l 146 | inPart = do reserved "in" 147 | e <- expr 148 | return $ e 149 | assign = do leout <- lexpr ; 150 | symbol "=" ; 151 | lookAhead (lower) 152 | fun <- identifier ; 153 | lein <- lexpr ; 154 | return $ (leout, fun, lein) 155 | caseofF= do reserved "case" 156 | lookAhead (lower) 157 | fun <- identifier 158 | le <- lexpr 159 | reserved "of" 160 | c <- many1 $ try cases 161 | return $ LetIn (Var "_tmp") fun le (CaseOf (Var "_tmp") c) 162 | caseof = do reserved "case" 163 | le <- lexpr 164 | reserved "of" 165 | c <- many1 $ try cases 166 | return $ CaseOf le c 167 | lefte = do le <- lexpr 168 | return $ LeftE le 169 | apply = do lookAhead (lower) 170 | fun <- identifier 171 | le <- lexpr 172 | notFollowedBy $ lexpr >> symbol "=^=" 173 | return $ LetIn (Var "_tmp") fun le (LeftE (Var "_tmp")) 174 | cases = cases_ 175 | cases_ = do le <- lexpr 176 | symbol "->" 177 | e <- expr 178 | return (le,e) 179 | 180 | constToConstr :: Int -> LExpr 181 | constToConstr n 182 | | n == 0 = Constr "Z" [] 183 | | n < 0 = Constr "P" [constToConstr (n+1)] 184 | | otherwise = Constr "S" [constToConstr (n-1)] 185 | 186 | lexpr :: LangParser LExpr 187 | lexpr = try consta <|> try vari <|> try tuple <|> try dupeq <|> try constr <|> try constrN <|> try list1 <|> try list2 <|> parenE 188 | where 189 | consta = do c <- constant 190 | return $ constToConstr c 191 | vari = do lookAhead (lower) 192 | var <- identifier 193 | return $ Var var 194 | tuple = do les <- braces $ lexpr `sepBy1` (symbol ",") 195 | return $ Constr "Tuple" les 196 | dupeq = do symbol "|" 197 | le <- lexpr 198 | symbol "|" 199 | return $ DupEq le 200 | constr = do lookAhead (upper) 201 | i <- identifier 202 | vars <- parens $ lexpr `sepBy` (symbol ",") 203 | return $ Constr i vars 204 | constrN= do lookAhead (upper) 205 | i <- identifier 206 | return $ Constr i [] 207 | list1 = parens $ chainr1 lexpr cons 208 | cons = do symbol ":"; return (\v1 v2 -> Constr "Cons" [v1,v2]) 209 | list2 = do l <- brackets $ lexpr `sepBy` (symbol ",") 210 | return $ foldr (\a b -> Constr "Cons" [a,b]) (Constr "Nil" []) l 211 | parenE = parens lexpr 212 | 213 | 214 | ------------------------------------------------------------------------------- 215 | -- * Parsing values 216 | ------------------------------------------------------------------------------- 217 | 218 | constToValue :: Int -> Value 219 | constToValue n 220 | | n == 0 = ConstrV "Z" [] 221 | | n < 0 = ConstrV "P" [constToValue (n+1)] 222 | | otherwise = ConstrV "S" [constToValue (n-1)] 223 | 224 | 225 | value :: LangParser Value 226 | value = try consta <|> try tuple <|> try constr <|> try constrN <|> try list <|> parenV 227 | where 228 | consta = do c <- constant 229 | return $ constToValue c 230 | tuple = do les <- braces $ value `sepBy1` (symbol ",") 231 | return $ ConstrV "Tuple" les 232 | constr = do i <- identifier 233 | vars <- parens $ value `sepBy` (symbol ",") 234 | return $ ConstrV i vars 235 | constrN= do i <- identifier 236 | return $ ConstrV i [] 237 | list = do l <- brackets $ value `sepBy` (symbol ",") 238 | return $ foldr (\a b -> ConstrV "Cons" [a,b]) (ConstrV "Nil" []) l 239 | parenV = parens value 240 | 241 | -------------------------------------------------------------------------------- /src/Core/Preparse.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Preparse 4 | -- Copyright : Michael Kirkedal Thomsen, 2013 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Preparse for rFun language 12 | -- 13 | -- Current purpose of this is to generate the function environment and 14 | -- de-sugar the function level pattern matching to case expressions. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Core.Preparse where 19 | 20 | import Core.Ast 21 | import qualified Data.Map as M 22 | import Data.List (nub) 23 | 24 | ------------------------------------------------------------------------------- 25 | -- * Pre-parse / de-sugar call function 26 | ------------------------------------------------------------------------------- 27 | 28 | -- |Pre-parse / de-sugar call function 29 | runPreparse :: Program -> FuncEnv 30 | runPreparse prog = M.fromList funcEnv 31 | where 32 | funcEnvSS = programToFuncEnvSS prog 33 | funcEnv = desugarArgPatMatch funcEnvSS 34 | 35 | -- |General function that applies a function to all function bodies in a program. 36 | applyToFunctionBody :: (Expr -> Expr) -> Program -> Program 37 | applyToFunctionBody fun prog = map app prog 38 | where 39 | app func = func{ body = fun $ body func } 40 | 41 | ------------------------------------------------------------------------------- 42 | -- ** Collecting functions of identical name for the function environment 43 | ------------------------------------------------------------------------------- 44 | 45 | -- |Generates a list of unique function names 46 | functionList :: Program -> [Ident] 47 | functionList program = nub $ map funcname program 48 | 49 | -- |Generates function environment from a list of functions 50 | programToFuncEnvSS :: Program -> [(Ident,[Func])] 51 | programToFuncEnvSS program = map (\x -> (x, filter (\y -> funcname y == x) program)) funlist 52 | where 53 | funlist = functionList program 54 | 55 | ------------------------------------------------------------------------------- 56 | -- ** De-sugar pattern matching in arguments, while preserving order 57 | ------------------------------------------------------------------------------- 58 | 59 | -- |De-sugar pattern matching in arguments, while preserving order 60 | desugarArgPatMatch :: [(Ident,[Func])] -> [(Ident,Func)] 61 | desugarArgPatMatch = map desugarArgPatMatchSingle 62 | where 63 | desugarArgPatMatchSingle (_ , []) = error "Function list cannot be empty" 64 | desugarArgPatMatchSingle (idt, [func]) = (idt, func) 65 | desugarArgPatMatchSingle (idt, funcs) = (idt, Func idt (Var "_ctmp") (CaseOf (Var "_ctmp") cases)) 66 | where 67 | cases = map (\x -> (param x, body x)) funcs 68 | 69 | ------------------------------------------------------------------------------- 70 | -- ** De-sugar function calls in expressions 71 | ------------------------------------------------------------------------------- 72 | --desugarApplyInExpr :: Expr -> Expr 73 | --desugarApplyInExpr (LetIn lExpr1 ident lExpr2 expr) = 74 | -- LetIn lExpr1 ident lExpr2 $ desugarApplyInExpr expr 75 | --desugarApplyInExpr (RLetIn lExpr1 ident lExpr2 expr) = 76 | -- RLetIn lExpr1 ident lExpr2 $ desugarApplyInExpr expr 77 | --desugarApplyInExpr (CaseOf lExpr cases) = 78 | -- CaseOf lExpr $ map (\(le,e) -> (le, desugarApplyInExpr e)) cases 79 | --desugarApplyInExpr (ApplyE ident lExpr) = 80 | -- LetIn (Var "_tmp") ident lExpr (LeftE (Var "_tmp")) 81 | --desugarApplyInExpr e = e 82 | 83 | ------------------------------------------------------------------------------- 84 | -- ** De-sugar many let assignments 85 | ------------------------------------------------------------------------------- 86 | --desugarManyLetIn :: Expr -> Expr 87 | --desugarManyLetIn (LetIns lets expr) = 88 | -- foldr (\(lExpr1, ident, lExpr2) e -> LetIn lExpr1 ident lExpr2 e) exprDS lets 89 | -- where 90 | -- exprDS = desugarManyLetIn expr 91 | --desugarManyLetIn (RLetIns lets expr) = 92 | -- foldr (\(lExpr1, ident, lExpr2) e -> RLetIn lExpr1 ident lExpr2 e) exprDS lets 93 | -- where 94 | -- exprDS = desugarManyLetIn expr 95 | --desugarManyLetIn (LetIn lExpr1 ident lExpr2 expr) = 96 | -- LetIn lExpr1 ident lExpr2 $ desugarManyLetIn expr 97 | --desugarManyLetIn (RLetIn lExpr1 ident lExpr2 expr) = 98 | -- RLetIn lExpr1 ident lExpr2 $ desugarManyLetIn expr 99 | --desugarManyLetIn (CaseOf lExpr cases) = 100 | -- CaseOf lExpr $ map (\(le,e) -> (le, desugarManyLetIn e)) cases 101 | --desugarManyLetIn e = e 102 | 103 | 104 | -------------------------------------------------------------------------------- /src/Core/RFun2Prog.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : RFun2Prog 4 | -- Copyright : Michael Kirkedal Thomsen, 2014 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Parses a RFun program to an input program for the self-interpreter. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Core.RFun2Prog (parseRFun) where 16 | 17 | import Core.Ast 18 | import Control.Monad.State 19 | import qualified Data.Map as M 20 | import Data.List (intercalate, sortBy) 21 | 22 | parseRFun :: Ident -> Program -> String 23 | parseRFun program funcs = evalState run (1, M.empty) 24 | where 25 | run = 26 | do 27 | s <- getFreshId program Function 28 | p <- parseProgram funcs 29 | g <- get 30 | let h = sortBy (\(_,x) (_,y) -> compare x y) $ M.toList $ snd g 31 | return $ "{" ++ show s ++ "," ++ stringList2 p ++ "}" ++ "\n\n" ++ show h 32 | 33 | 34 | parseProgram :: Program -> IntNames [String] 35 | parseProgram funcs = 36 | do 37 | list <- mapM parseFunc funcs 38 | let slist = sortBy (\(x,_) (y,_) -> compare x y) list 39 | sslist = myscan 0 slist 40 | return $ map (\(x,y) -> "{" ++ show x ++ "," ++ y ++ "}") sslist 41 | where 42 | myscan _ [] = [] 43 | myscan a ((x,y):xs) = (x-a,y):(myscan x xs) 44 | 45 | parseFunc :: Func -> IntNames (Int,String) 46 | parseFunc func = 47 | do 48 | fId <- getFreshId (funcname func) Function 49 | pId <- parseLExpr $ param func 50 | bod <- parseExpr $ body func 51 | return $ (fId, "{"++ pId ++ "," ++ bod ++ "}") 52 | 53 | parseExpr :: Expr -> IntNames String 54 | parseExpr (LeftE lExpr) = 55 | do 56 | lexp <- parseLExpr lExpr 57 | return $ "LeftE(" ++ lexp ++ ")" 58 | parseExpr (LetIn lExpr1 ident lExpr2 expr) = 59 | do 60 | fId <- getFreshId ident Function 61 | lex1 <- parseLExpr lExpr1 62 | lex2 <- parseLExpr lExpr2 63 | ex <- parseExpr expr 64 | return $ "LetIn(" ++ lex1 ++ "," ++ show fId ++ "," ++ lex2 ++ "," ++ ex ++ ")" 65 | parseExpr (RLetIn lExpr1 ident lExpr2 expr) = 66 | do 67 | fId <- getFreshId ident Function 68 | lex1 <- parseLExpr lExpr1 69 | lex2 <- parseLExpr lExpr2 70 | ex <- parseExpr expr 71 | return $ "RLetIn(" ++ lex1 ++ "," ++ show fId ++ "," ++ lex2 ++ "," ++ ex ++ ")" 72 | parseExpr (CaseOf lExpr cases) = 73 | do 74 | lexp <- parseLExpr lExpr 75 | cas <- mapM (\(x,y) -> do {l <- parseLExpr x; e <- parseExpr y; return $ "{" ++ l ++ "," ++ e ++ "}"}) cases 76 | return $ "CaseOf(" ++ lexp ++ "," ++ stringList cas ++ ")" 77 | 78 | -- | CaseOf LExpr [(LExpr, Expr)] -- ^ Case-of expression 79 | 80 | parseLExpr :: LExpr -> IntNames String 81 | parseLExpr (Var ident) = 82 | do 83 | vId <- getFreshId ident Variable 84 | return $ "Var(" ++ show vId ++ ")" 85 | parseLExpr (Constr ident lExprs) = 86 | do 87 | lexps <- mapM parseLExpr lExprs 88 | return $ "Constr(" ++ ident ++ "," ++ stringList lexps ++ ")" 89 | parseLExpr (DupEq lExpr) = 90 | do 91 | lexp <- parseLExpr lExpr 92 | return $ "DupEq(" ++ lexp ++ ")" 93 | 94 | stringList :: [String] -> String 95 | stringList list = "[" ++ intercalate "," list ++ "]" 96 | 97 | stringList2 :: [String] -> String 98 | stringList2 list = "[" ++ intercalate ",\n" list ++ "]" 99 | 100 | -- Contains the next var name, a mapping 101 | data Type = Function | Variable 102 | deriving (Show, Eq, Ord) 103 | type Subst = M.Map (Ident,Type) Int 104 | type IntNames a = State (Int, Subst) a 105 | 106 | -- |Returns the fresh name of a given identifier 107 | getFreshId :: Ident -> Type -> IntNames Int 108 | getFreshId ident typ = 109 | do (nextId, subs) <- get 110 | let (curId, updates) = update nextId subs 111 | put updates 112 | return $ curId 113 | where 114 | update nID s = 115 | case M.lookup (ident, typ) s of 116 | Just(val) -> (val, (nID, s)) 117 | Nothing -> (nID, (nID + 1, M.insert (ident, typ) nID s)) 118 | 119 | -------------------------------------------------------------------------------- /src/Interp.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : Interp 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Simple translation of RFun17 to RFun_core for interpretation 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Interp (interp) where 16 | 17 | import Ast 18 | import qualified Core.Ast as C 19 | import Core.Preparse (runPreparse) 20 | import Core.Interp (runProg) 21 | 22 | import Data.Maybe (catMaybes) 23 | 24 | 25 | -- res <- fromError $ runProg program val funEnv 26 | 27 | -- fromError :: Either ErrorRFun (Value, EvalTrace) -> IO Value 28 | -- fromError (Left err) = putStr (err ++ "\n") >> (exitWith $ ExitFailure 1) 29 | -- fromError (Right a) = return $ fst a 30 | 31 | 32 | interp :: Program -> String -> [Value] -> Either String Value 33 | interp p i vs = 34 | -- Left $ C.prettyFuncEnv funEnv 35 | case runProg i (tcValues vs) funEnv of 36 | (Left err) -> Left $ err ++ "\n\n" ++ (C.prettyFuncEnv funEnv) 37 | (Right a) -> fromCoreValue $ fst a 38 | where 39 | pCore = toCore p 40 | funEnv = runPreparse $ pCore 41 | 42 | fromCoreValue :: C.Value -> Either String Value 43 | fromCoreValue (C.ConstrV "Tuple" vs) = Right $ fcValue $ last vs 44 | fromCoreValue v = Left $ show $ fcValue v 45 | 46 | toCore :: Program -> C.Program 47 | toCore p = (C.Func "id" (C.Var "_ctmp") (C.LeftE (C.Var "_ctmp"))): 48 | (C.Func "eq" (C.Var "_ctmp") 49 | (C.CaseOf (C.DupEq (C.Var "_ctmp")) 50 | [(C.Constr "Tuple" [C.Var "_ctmp"], C.LeftE (C.Constr "Tuple" [C.Var "_ctmp", C.Constr "Eq" []])), 51 | (C.Constr "Tuple" [C.Var "_ctmp", C.Var "_ctmp2"], C.LeftE (C.Constr "Tuple" [C.Var "_ctmp", C.Constr "Neq" [C.Var "_ctmp2"]]))])): 52 | (catMaybes $ map tcFunc p) 53 | 54 | tcFunc :: Func -> Maybe C.Func 55 | tcFunc (Func ident _ clauses) = Just $ C.Func (tcIdent ident) (C.Var "_ctmp") (C.CaseOf (C.Var "_ctmp") (map tcClause clauses)) 56 | tcFunc _ = Nothing 57 | 58 | tcClause :: Clause -> (C.LExpr, C.Expr) 59 | tcClause (Clause _ params _ expr) = ((C.Constr "Tuple" lExprs), e) 60 | where 61 | lExprs = map tcLExpr params 62 | e = tcExpr (init lExprs) expr 63 | 64 | tcExpr :: [C.LExpr] -> Expr -> C.Expr 65 | tcExpr params (LeftE (App ident True lExprs)) = 66 | C.LetIn (C.Constr "Tuple" ((init les) ++ [C.Var "_ctmp"])) (tcIdent ident) (C.Constr "Tuple" les) 67 | (C.LeftE $ C.Constr "Tuple" (params ++ [C.Var "_ctmp"])) 68 | where 69 | les = map tcLExpr lExprs 70 | tcExpr params (LeftE (App ident False lExprs)) = 71 | C.RLetIn (C.Constr "Tuple" les) (tcIdent ident) (C.Constr "Tuple" ((init les) ++ [C.Var "_ctmp"])) 72 | (C.LeftE $ C.Constr "Tuple" (params ++ [C.Var "_ctmp"])) 73 | where 74 | les = map tcLExpr lExprs 75 | tcExpr params (LeftE lExpr) = C.LeftE $ C.Constr "Tuple" (params ++ [tcLExpr lExpr]) 76 | tcExpr params (CaseOf app@(App _ _ _) cases) = tcExpr params $ LetIn (Var $ makeIdent "tmp_coApp") app (CaseOf (Var $ makeIdent "tmp_coApp") cases) 77 | tcExpr params (CaseOf lExpr cases) = C.CaseOf (tcLExpr lExpr) (map (\(le,_,e) -> (tcLExpr le, tcExpr params e)) cases) 78 | tcExpr params (LetIn leftLE (App ident True funLEs) expr) = -- Forward application 79 | C.LetIn (C.Constr "Tuple" leftLEs) (tcIdent ident) (C.Constr "Tuple" rightLEs) (tcExpr params expr) 80 | where 81 | rightLEs = map tcLExpr funLEs 82 | leftLEs = (init rightLEs) ++ [tcLExpr leftLE] 83 | tcExpr params (LetIn leftLE (App ident False funLEs) expr) = -- Backward application 84 | C.RLetIn (C.Constr "Tuple" leftLEs) (tcIdent ident) (C.Constr "Tuple" rightLEs) (tcExpr params expr) 85 | where 86 | leftLEs = map tcLExpr funLEs 87 | rightLEs = (init leftLEs) ++ [tcLExpr leftLE] 88 | tcExpr params (LetIn leftLE rightLE expr) = C.LetIn (tcLExpr leftLE) "id" (tcLExpr rightLE) (tcExpr params expr) -- No function application 89 | 90 | -- extractApps :: LExpr -> ([LExpr], LExpr) 91 | 92 | tcLExpr :: LExpr -> C.LExpr 93 | tcLExpr (Var ident) = C.Var $ tcIdent ident 94 | tcLExpr (Constr ident lExprs) = C.Constr (tcIdent ident) (map tcLExpr lExprs) 95 | tcLExpr (Int integer) = constToConstr integer 96 | tcLExpr (Tuple lExprs) = C.Constr "Tuple" (map tcLExpr lExprs) 97 | tcLExpr (List (ListCons lExpr lExprList)) = C.Constr "Cons" [tcLExpr lExpr, tcLExpr (List lExprList)] 98 | tcLExpr (List (ListEnd lExpr)) = tcLExpr lExpr 99 | tcLExpr (List ListNil) = C.Constr "Nil" [] 100 | tcLExpr (App _ _ _) = error "" 101 | 102 | tcIdent :: Ident -> C.Ident 103 | tcIdent (Ident s _) = s 104 | 105 | tcValues :: [Value] -> C.Value 106 | tcValues vs = C.ConstrV "Tuple" (map tcValue vs) 107 | 108 | tcValue :: Value -> C.Value 109 | tcValue (IntV integer) = constToValue integer 110 | tcValue (TupleV values) = C.ConstrV "Tuple" (map tcValue values) 111 | tcValue (ListV []) = C.ConstrV "Nil" [] 112 | tcValue (ListV (v:vs)) = C.ConstrV "Cons" [tcValue v, tcValue (ListV vs)] 113 | tcValue (ConstrV ident values) = C.ConstrV ident (map tcValue values) 114 | tcValue (FunV i) = C.ConstrV i [] 115 | 116 | fcValue :: C.Value -> Value 117 | fcValue (C.ConstrV "Z" []) = IntV 0 118 | fcValue (C.ConstrV "S" [c]) = 119 | case fcValue c of 120 | IntV i -> IntV $ i + 1 121 | v -> ConstrV "S" [v] 122 | fcValue (C.ConstrV "P" [c]) = 123 | case fcValue c of 124 | IntV i -> IntV $ i - 1 125 | v -> ConstrV "P" [v] 126 | fcValue (C.ConstrV "Tuple" vs) = TupleV $ map fcValue vs 127 | fcValue (C.ConstrV "Nil" []) = ListV [] 128 | fcValue (C.ConstrV "Cons" [v1,v2]) = 129 | case fcValue v2 of 130 | ListV t -> ListV $ (fcValue v1):t 131 | v -> ConstrV "Cons" [fcValue v1,v] 132 | fcValue (C.ConstrV c vs) = ConstrV c $ map fcValue vs 133 | 134 | constToValue :: Integer -> C.Value 135 | constToValue n 136 | | n == 0 = C.ConstrV "Z" [] 137 | | n < 0 = C.ConstrV "P" [constToValue (n+1)] 138 | | otherwise = C.ConstrV "S" [constToValue (n-1)] 139 | 140 | constToConstr :: Integer -> C.LExpr 141 | constToConstr n 142 | | n == 0 = C.Constr "Z" [] 143 | | n < 0 = C.Constr "P" [constToConstr (n+1)] 144 | | otherwise = C.Constr "S" [constToConstr (n-1)] 145 | -------------------------------------------------------------------------------- /src/MainCore.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Main 4 | -- Copyright : Michael Kirkedal Thomsen, 2013 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : None guaranteed? 9 | -- Portability : 10 | -- 11 | -- |Main file for interpreting RFun 12 | -- 13 | -- The language is based on, to which the are make references in the comments: 14 | -- 15 | -- T. Yokoyama, H. B. Axelsen, and R. Gluck 16 | -- Towards a reversible functional language 17 | -- LNCS vol. 7165, pp. 14--29, 2012 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Main (main) where 22 | 23 | import Core.Ast 24 | import Core.Parser (parseFromFile, parseValue, parseString, ParseError) 25 | import Core.Preparse (runPreparse) 26 | import Core.Interp (runProg, ErrorRFun, EvalTrace) 27 | import Core.RFun2Prog (parseRFun) 28 | import System.Environment 29 | import System.Exit 30 | -- import System.Timeout 31 | import qualified Data.Map as M 32 | 33 | 34 | -- |Main function 35 | main :: IO () 36 | main = 37 | do 38 | args <- getArgs 39 | case args of 40 | [program, value, filename] -> 41 | do 42 | -- res <- timeout (5 * 1000000) $ parseAndRun program value filename -- 5 second 43 | res <- parseAndRun program value filename >>= \x -> return $ Just x 44 | 45 | case res of 46 | Nothing -> exitWith $ ExitFailure 124 47 | _ -> return () 48 | [filename, program] -> parsePreAndRFun filename program 49 | [filename] -> parseAndPre filename 50 | _ -> putStrLn "Bad args. Usage: \"main\" startfunc startvalue programfile\nor to stop before interpretation: \"main\" programfile " 51 | 52 | 53 | parseAndRun :: String -> String -> String -> IO () 54 | parseAndRun program value filename = 55 | do 56 | prg <- fromParsecError =<< parseInput filename 57 | val <- fromParsecError =<< parseValue value 58 | let funEnv = runPreparse prg 59 | res <- fromError $ runProg program val funEnv 60 | putStrLn $ pretty res 61 | 62 | parseAndPre :: String -> IO () 63 | parseAndPre filename = 64 | do 65 | prg <- fromParsecError =<< parseInput filename 66 | let funEnv = runPreparse prg 67 | putStrLn $ prettyFuncEnv funEnv 68 | putStrLn "Parsing successful." 69 | 70 | parsePreAndRFun :: String -> Ident -> IO () 71 | parsePreAndRFun filename program = 72 | do 73 | prg <- fromParsecError =<< parseInput filename 74 | let funEnv = runPreparse prg 75 | putStrLn $ prettyFuncEnv funEnv 76 | putStrLn $ parseRFun program $ map snd $ M.toList funEnv 77 | 78 | parseInput :: String -> IO (Either ParseError Program) 79 | parseInput "-" = parseString =<< getContents 80 | parseInput file = parseFromFile file 81 | 82 | fromParsecError :: Either ParseError a -> IO a 83 | fromParsecError (Left err) = putStr ((show err) ++ "\n") >> (exitWith $ ExitFailure 1) 84 | fromParsecError (Right a) = return a 85 | 86 | fromError :: Either ErrorRFun (Value, EvalTrace) -> IO Value 87 | fromError (Left err) = putStr (err ++ "\n") >> (exitWith $ ExitFailure 1) 88 | fromError (Right a) = return $ fst a 89 | -------------------------------------------------------------------------------- /src/MainRFun.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : TypeCheck 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Main execution of RFun17 interpreter 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Main (main) where 16 | 17 | import Parser 18 | import Ast 19 | import PrettyPrinter 20 | import TypeCheck 21 | import Interp 22 | 23 | import System.Environment 24 | import System.Exit 25 | 26 | 27 | main :: IO () 28 | main = 29 | do 30 | args <- getArgs 31 | case args of 32 | (filename : program : values) -> 33 | do p <- parseProgram filename 34 | vs <- parseValues values 35 | typecheckProgram p 36 | case interp p program vs of 37 | (Left err) -> putStrLn "Run-time error:" >> (putStrLn $ err) 38 | (Right val) -> putStrLn $ ppValue val 39 | [filename] -> parseProgram filename >>= typecheckProgram >>= prettyPrintProgram 40 | _ -> putStrLn "Wrong number of arguments.\nUsage:\n \"rfun\" programfile startfunc startvalue+\nor to stop before interpretation:\n \"rfun\" programfile " 41 | 42 | typecheckProgram :: Program -> IO Program 43 | typecheckProgram p = 44 | case typecheck p of 45 | Nothing -> return p 46 | (Just e) -> putStrLn e >> (exitWith $ ExitFailure 1) 47 | 48 | prettyPrintProgram :: Program -> IO () 49 | prettyPrintProgram = putStrLn.ppProgram 50 | 51 | 52 | loadFile :: String -> IO String 53 | loadFile "-" = getContents 54 | loadFile filename = readFile filename 55 | 56 | parseProgram :: String -> IO Program 57 | parseProgram filename = loadFile filename >>= parseFromString >>= fromParserError 58 | 59 | parseValues :: [String] -> IO [Value] 60 | parseValues strV = 61 | do l <- fromParserError $ mapM parseFromValue strV 62 | return $ concat l 63 | 64 | fromParserError :: Either ParserError a -> IO a 65 | fromParserError (Left err) = (putStr (prettyParseError err)) >> (exitWith $ ExitFailure 1) 66 | fromParserError (Right a) = return a 67 | 68 | -------------------------------------------------------------------------------- /src/MainWeb.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : TypeCheck 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Main execution of RFun17 interpreter 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Main (main) where 16 | 17 | import Parser 18 | import Ast 19 | import PrettyPrinter 20 | import TypeCheck 21 | import Interp 22 | 23 | import System.Environment 24 | import System.Exit 25 | import System.Timeout 26 | 27 | 28 | main :: IO () 29 | main = 30 | do 31 | args <- getArgs 32 | case args of 33 | (filename : program : values) -> 34 | do p <- parseProgram filename 35 | vs <- parseValues values 36 | typecheckProgram p 37 | res <- timeout (5 * 1000000) $ (return $ interp p program vs) 38 | case res of 39 | (Just (Left err)) -> putStrLn "Run-time error:" >> (putStrLn $ err) 40 | (Just (Right val)) -> putStrLn $ ppValue val 41 | Nothing -> exitWith $ ExitFailure 124 42 | [filename] -> parseProgram filename >>= typecheckProgram >>= prettyPrintProgram 43 | _ -> putStrLn "Wrong number of arguments.\nUsage:\n \"rfun\" programfile startfunc startvalue+\nor to stop before interpretation:\n \"rfun\" programfile " 44 | 45 | typecheckProgram :: Program -> IO Program 46 | typecheckProgram p = 47 | case typecheck p of 48 | Nothing -> return p 49 | (Just e) -> putStrLn e >> (exitWith $ ExitFailure 1) 50 | 51 | prettyPrintProgram :: Program -> IO () 52 | prettyPrintProgram = putStrLn.ppProgram 53 | 54 | 55 | loadFile :: String -> IO String 56 | loadFile "-" = getContents 57 | loadFile filename = readFile filename 58 | 59 | parseProgram :: String -> IO Program 60 | parseProgram filename = loadFile filename >>= parseFromString >>= fromParserError 61 | 62 | parseValues :: [String] -> IO [Value] 63 | parseValues strV = 64 | do l <- fromParserError $ mapM parseFromValue strV 65 | return $ concat l 66 | 67 | fromParserError :: Either ParserError a -> IO a 68 | fromParserError (Left err) = (putStr (prettyParseError err)) >> (exitWith $ ExitFailure 1) 69 | fromParserError (Right a) = return a 70 | 71 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | RFUNFILES=Ast.hs MainWeb.hs MainRFun.hs Parser.hs PrettyPrinter.hs TypeCheck.hs Interp.hs 2 | COREFILES=MainCore.hs Core/Ast.hs Core/Interp.hs Core/Parser.hs Core/Preparse.hs Core/RFun2Prog.hs 3 | BNFC=rfun.cf 4 | 5 | rfun: $(RFUNFILES) 6 | ghc --make -o rfun -Wall -fno-warn-unused-do-bind -XGeneralizedNewtypeDeriving MainRFun.hs 7 | 8 | core: $(COREFILES) 9 | ghc --make -o rfunCore -Wall -fno-warn-unused-do-bind -XGeneralizedNewtypeDeriving MainCore.hs 10 | 11 | web: $(RFUNFILES) 12 | ghc -O2 -o ../bin/rfun -rtsopts --make -XGeneralizedNewtypeDeriving MainWeb.hs 13 | 14 | optimized opt: $(RFUNFILES) 15 | ghc -O2 -o ../bin/rfun -rtsopts --make -XGeneralizedNewtypeDeriving MainRFun.hs 16 | 17 | haddock h: $(RFUNFILES) 18 | haddock -h -o ../docs/ MainRFun.hs 19 | 20 | clean: 21 | rm -f $(subst .hs,.o,$(RFUNFILES)) 22 | rm -f $(subst .hs,.hi,$(RFUNFILES)) 23 | rm -f rfun 24 | rm -f $(subst .hs,.o,$(COREFILES)) 25 | rm -f $(subst .hs,.hi,$(COREFILES)) 26 | rm -f rfunCore 27 | rm -f *.bak 28 | 29 | test: 30 | (cd ../test; sh MyTest.txt) 31 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : Parser 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Parser for RFun17 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Parser (parseFromFile, parseFromString, parseFromValue, prettyParseError, ParserError) where 16 | 17 | import Ast 18 | 19 | import Control.Applicative (empty) 20 | import Control.Monad (void, guard, when, forM_) 21 | import Text.Megaparsec 22 | import Text.Megaparsec.String 23 | import qualified Text.Megaparsec.Lexer as L 24 | import qualified Data.Map as M 25 | 26 | -- import Data.Complex 27 | 28 | type ParserError = ParseError Char Dec 29 | 30 | prettyParseError :: ParserError -> String 31 | prettyParseError = parseErrorPretty 32 | 33 | parseFromFile :: FilePath -> IO (Either ParserError Program) 34 | parseFromFile fname = 35 | do input <- readFile fname 36 | return (parse programParser fname input) 37 | 38 | parseFromString :: String -> IO (Either ParserError Program) 39 | parseFromString input = 40 | return (parse programParser "WebForm" input) 41 | 42 | parseFromValue :: String -> Either ParserError [Value] 43 | parseFromValue s = parse (some pValue) "Value" s 44 | 45 | lineComment :: Parser () 46 | lineComment = L.skipLineComment "--" 47 | 48 | scn :: Parser () 49 | scn = L.space (void spaceChar) lineComment empty 50 | 51 | sc :: Parser () 52 | sc = L.space (void $ oneOf " \t") lineComment empty 53 | 54 | lexeme :: Parser a -> Parser a 55 | lexeme = L.lexeme sc 56 | 57 | programParser :: Parser Program 58 | programParser = pProgram <* scn <* eof 59 | 60 | --- 61 | 62 | integer :: Parser Integer 63 | integer = lexeme $ L.signed sc L.integer 64 | 65 | 66 | symbol :: String -> Parser () 67 | symbol s = L.symbol' sc s >> return () 68 | 69 | reservedWords :: [String] 70 | reservedWords = ["let", "in", "case", "of", "data"] 71 | 72 | reserved :: String -> Parser () 73 | reserved s = lexeme $ (string s >> return ()) 74 | 75 | parens :: Parser a -> Parser a 76 | parens = between (symbol "(") (symbol ")") 77 | 78 | brackets :: Parser a -> Parser a 79 | brackets = between (symbol "[") (symbol "]") 80 | 81 | pIdentifier :: Parser Ident 82 | pIdentifier = (lexeme $ p) 83 | where 84 | p = do 85 | lookAhead lowerChar 86 | pos <- getPosition 87 | str <- some (alphaNumChar <|> char '-' <|> char '_' <|> char '\'' "identifier that is not a keyword: " ++ show reservedWords) 88 | guard (not $ elem str reservedWords) 89 | return $ Ident str pos 90 | 91 | pConstructor :: Parser Ident 92 | pConstructor = lexeme $ p 93 | where 94 | p = do 95 | lookAhead upperChar 96 | pos <- getPosition 97 | str <- some (alphaNumChar <|> char '-' <|> char '_' "constructor name") 98 | return $ Ident str pos 99 | 100 | -- 101 | 102 | pProgram :: Parser Program 103 | pProgram = some $ (try pDataType <|> pFunDef) 104 | 105 | pFunDef :: Parser Func 106 | pFunDef = 107 | do (idt, tps) <- try pTypeSig "function signature" 108 | cls <- (some $ try (pFunDefClause $ identifier idt)) 109 | return $ Func idt tps cls 110 | 111 | pDataType :: Parser Func 112 | pDataType = L.nonIndented scn $ L.lineFold scn p 113 | where 114 | p sc' = 115 | do reserved "data" "data type" 116 | i <- pConstructor 117 | symbol "=" 118 | sc' 119 | ts <- item `sepBy1` (symbol "|") 120 | return $ DataType i (M.fromList $ map (\x -> (identifier $ fst x, x)) ts) 121 | item = 122 | do i <- pConstructor 123 | ts <- many btype 124 | return (i, ts) 125 | 126 | 127 | pTypeSig :: Parser (Ident, Maybe TypeSig) 128 | pTypeSig = L.nonIndented scn p 129 | where 130 | p = do 131 | idt <- lookAhead pIdentifier 132 | tps <- optional $ try t 133 | return (idt, tps) 134 | t = do 135 | pIdentifier 136 | symbol "::" 137 | typeSig 138 | 139 | typeSig :: Parser TypeSig 140 | typeSig = 141 | do at <- many $ try eType -- Ancillae types 142 | lt <- btype -- left type 143 | symbol "<->" 144 | rt <- btype -- right type 145 | return $ TypeSig at lt rt 146 | where 147 | eType = do t <- extType 148 | symbol "->" 149 | return t 150 | 151 | extType :: Parser BType 152 | extType = try btype <|> funT 153 | where 154 | funT = do t <- parens typeSig 155 | return $ FunT t 156 | 157 | btype :: Parser BType 158 | btype = try intT <|> try qbitT <|> try list <|> try tuple <|> try dataT <|> try anyT <|> parens btype 159 | where 160 | intT = symbol "Int" >> return IntT 161 | qbitT = symbol "Qbit" >> return QbitT 162 | list = do t <- brackets btype 163 | return $ ListT t 164 | tuple = do t <- parens $ sepBy btype (symbol ",") 165 | return $ ProdT t 166 | dataT = do i <- pConstructor 167 | return $ DataT i 168 | anyT = do i <- pIdentifier 169 | return $ VarT i 170 | 171 | pFunDefClause :: String -> Parser Clause 172 | pFunDefClause iTps = L.nonIndented scn $ L.lineFold scn p 173 | where 174 | p sc' = do idt <- pIdentifier 175 | guard ((identifier idt) == iTps) 176 | les <- some pLexpr 177 | gs <- pGuard 178 | symbol "=" 179 | sc' 180 | e <- pExpr 181 | return $ Clause idt les gs e 182 | 183 | pGuard :: Parser Guard 184 | pGuard = try someguard <|> (return $ Guard []) 185 | where 186 | someguard = 187 | do symbol "|" 188 | gs <- sepBy1 pLexprA (symbol ",") 189 | return $ Guard gs 190 | 191 | pExpr :: Parser Expr 192 | pExpr = (L.lineFold scn letin) <|> caseof <|> lefte "expression" 193 | where 194 | letin sc' = do il <- L.indentLevel 195 | reserved "let" 196 | sc' 197 | il_l <- L.indentLevel 198 | l <- some $ try assign 199 | forM_ l (\(_,_,i) -> when (il_l /= i) (L.incorrectIndent EQ il_l i)) 200 | scn 201 | L.indentGuard sc EQ il 202 | reserved "in" 203 | sc' 204 | e <- pExpr 205 | return $ foldr (\(lExpr1, lExpr2, _) ex -> LetIn lExpr1 lExpr2 ex) e l 206 | assign = do scn 207 | il <- L.indentLevel 208 | leout <- pLexpr 209 | symbol "=" 210 | lein <- pLexprA 211 | return $ (leout, lein, il) 212 | caseof = do il <- L.indentLevel 213 | reserved "case" 214 | le <- pLexprA 215 | reserved "of" 216 | scn 217 | L.indentGuard scn GT il 218 | il_l <- L.indentLevel 219 | c <- some $ try (L.lineFold scn cases) 220 | forM_ c (\(_,_,_,i) -> when (il_l /= i) (L.incorrectIndent EQ il_l i)) 221 | return $ CaseOf le $ map (\(x,y,z,_) -> (x,y,z)) c 222 | cases sc' = do scn 223 | il <- L.indentLevel 224 | le <- pLexpr 225 | -- gs <- guard 226 | symbol "->" 227 | sc' 228 | e <- pExpr 229 | return (le, (Guard []), e, il) 230 | lefte = do le <- pLexprA 231 | return $ LeftE le 232 | 233 | -- |Parsing a basic left-expression 234 | pLexpr :: Parser LExpr 235 | pLexpr = constr <|> vari <|> int <|> listf <|> try (parens constrp) <|> try tuple <|> try listc <|> parLE "Left-expression" 236 | where 237 | int = do i <- integer 238 | return $ Int i 239 | vari = do var <- pIdentifier 240 | return $ Var var 241 | constr = do c <- pConstructor 242 | return $ Constr c [] 243 | constrp= do c <- pConstructor 244 | vars <- many pLexpr 245 | return $ Constr c vars 246 | tuple = do les <- parens $ pLexpr `sepBy` (symbol ",") 247 | return $ Tuple les 248 | listc = do les <- parens $ pLexpr `sepBy1` (symbol ":") 249 | return $ List $ foldr (\a b -> ListCons a b) (ListEnd $ last les) (init les) 250 | listf = do les <- brackets $ pLexpr `sepBy` (symbol ",") 251 | return $ List $ foldr (\a b -> ListCons a b) ListNil les 252 | parLE = parens pLexpr 253 | 254 | -- |Parsing a complete left-expression; including function application 255 | pLexprA :: Parser LExpr 256 | pLexprA = try app <|> try pLexpr <|> parLE "Left-expression" 257 | where 258 | app = do fun <- pIdentifier 259 | inv <- optional $ symbol "!" 260 | les <- some pLexpr 261 | return $ App fun (inv == Nothing) les 262 | parLE = parens pLexprA 263 | 264 | 265 | pValue :: Parser Value 266 | pValue = int <|> list <|> funName <|> constr <|> try (parens constrp) <|> try tuple "Value" 267 | where 268 | int = do i <- integer 269 | return $ IntV i 270 | tuple = do vs <- parens $ pValue `sepBy` (symbol ",") 271 | return $ TupleV vs 272 | list = do vs <- brackets $ pValue `sepBy` (symbol ",") 273 | return $ ListV vs 274 | constr = do c <- pConstructor 275 | return $ ConstrV (identifier c) [] 276 | constrp= do c <- pConstructor 277 | vars <- many pValue 278 | return $ ConstrV (identifier c) vars 279 | funName= do i <- pIdentifier 280 | return $ FunV $ identifier i 281 | par = parens pValue 282 | 283 | -------------------------------------------------------------------------------- /src/PrettyPrinter.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : PrettyPrinter 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Pretty printer for RFun17 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module PrettyPrinter (ppProgram, ppTypeSig, ppBType, ppLExpr, ppIdent, ppIdentFile, ppIdentPos, ppIdentLine, ppValue) where 16 | 17 | import Ast 18 | 19 | import Text.PrettyPrint 20 | import Data.List (intersperse) 21 | import Text.Megaparsec (sourceName, sourceLine, sourceColumn, Pos, unPos) 22 | import qualified Data.Map as M 23 | -- import Text.Megaparsec.Pos (unPos) 24 | 25 | -- import Data.Complex 26 | 27 | ppProgram :: Program -> String 28 | ppProgram = render . formatProgram 29 | 30 | ppBType :: BType -> String 31 | ppBType = render . formatBType 32 | 33 | ppTypeSig :: TypeSig -> String 34 | ppTypeSig = render . formatTypeSig 35 | 36 | ppLExpr :: LExpr -> String 37 | ppLExpr = render . formatLExpr 38 | 39 | ppIdent :: Ident -> String 40 | ppIdent = render . formatIdent 41 | 42 | ppIdentFile :: Ident -> String 43 | ppIdentFile = sourceName . sourcePos 44 | 45 | ppIdentPos :: Ident -> String 46 | ppIdentPos i = "line " ++ (showPos $ sourceLine $ sourcePos i) ++ ", column " ++ (showPos $ sourceColumn $ sourcePos i) 47 | 48 | ppIdentLine :: Ident -> String 49 | ppIdentLine i = "line " ++ (showPos $ sourceLine $ sourcePos i) 50 | 51 | ppValue :: Value -> String 52 | ppValue = render . formatValue 53 | 54 | 55 | showPos :: Pos -> String 56 | showPos = show . unPos 57 | 58 | formatProgram :: Program -> Doc 59 | formatProgram p = 60 | (vcat $ intersperse (text "") $ map formatFunc p) 61 | 62 | formatFunc :: Func -> Doc 63 | formatFunc func@(Func _ _ _) = 64 | case funcTypesig func of 65 | Nothing -> vcat $ map (formatClause (funcName func)) $ funcClause func 66 | (Just sig) -> formatIdent (funcName func) <+> text "::" <+> formatTypeSig sig $+$ 67 | (vcat $ map (formatClause (funcName func)) $ funcClause func) 68 | formatFunc (DataType dataN dataD) = 69 | text "data" <+> formatIdent dataN <+> text "=" <+> 70 | (hsep $ intersperse (text "|") $ map (\(_,(i,b)) -> formatIdent i <+> (hsep (map (formatBType) b))) (M.toList dataD)) 71 | 72 | formatClause :: Ident -> Clause -> Doc 73 | formatClause ident clause = 74 | case clauseBody clause of 75 | (LeftE l) -> formatIdent ident <+> 76 | (hsep $ map formatLExpr (clauseParam clause)) <+> 77 | formatGuard (clauseGuard clause) <+> 78 | text "=" <+> formatLExpr l 79 | e -> formatIdent ident <+> 80 | (hsep $ map formatLExpr (clauseParam clause)) <+> 81 | formatGuard (clauseGuard clause) <+> 82 | text "=" $+$ (nest 2 $ formatExpr e) 83 | 84 | formatGuard :: Guard -> Doc 85 | formatGuard (Guard []) = empty 86 | formatGuard (Guard g) = text "|" <+> commaSep formatLExpr g 87 | 88 | formatTypeSig :: TypeSig -> Doc 89 | formatTypeSig (TypeSig ancT leftT rightT) = 90 | (hcat $ map (\x -> formatBType x <> text " -> ") ancT) <> formatBType leftT <+> text "<->" <+> formatBType rightT 91 | 92 | formatBType :: BType -> Doc 93 | -- formatBType NatT = text "Nat" 94 | formatBType IntT = text "Int" 95 | formatBType QbitT = text "Qbit" 96 | formatBType (DataT ident) = formatIdent ident 97 | formatBType (ListT bType) = brackets $ formatBType bType 98 | formatBType (ProdT bTypes) = parens $ commaSep formatBType bTypes 99 | formatBType (SumT bTypes) = parens $ hsep $ intersperse (text "+") $ map formatBType bTypes 100 | formatBType (FunT typeSig) = parens $ formatTypeSig typeSig 101 | formatBType (VarT ident) = formatIdent ident 102 | formatBType (AnyT) = text "a" -- Introduce new vars 103 | 104 | 105 | formatExpr :: Expr -> Doc 106 | formatExpr (LeftE le) = formatLExpr le 107 | formatExpr e@(LetIn _ _ _) = formatLetIn False e 108 | where 109 | formatLetIn True (LetIn left right expr@(LetIn _ _ _)) = 110 | formatLExpr left <+> text "=" <+> formatLExpr right $+$ formatLetIn True expr 111 | formatLetIn True (LetIn left right expr) = -- Not followed by let-in 112 | formatLExpr left <+> text "=" <+> formatLExpr right $+$ (nest (-2) $ text "in") $+$ formatExpr expr 113 | formatLetIn False (LetIn left right expr@(LetIn _ _ _)) = 114 | text "let" $+$ nest 2 (formatLExpr left <+> text "=" <+> formatLExpr right $+$ formatLetIn True expr) 115 | formatLetIn False (LetIn left right expr) = -- Not followed by let-in 116 | text "let" $+$ nest 2 (formatLExpr left <+> text "=" <+> formatLExpr right $+$ (nest (-2) $ text "in") $+$ formatExpr expr) 117 | formatLetIn _ _ = error "... In format of Expr" 118 | formatExpr (CaseOf lexpr cases) = 119 | text "case" <+> formatLExpr lexpr <+> text "of" $+$ (nest 2 $ vcat $ map formatcase cases) 120 | where 121 | formatcase (l, _, (LeftE le)) = formatLExpr l <+> text "->" <+> formatLExpr le 122 | formatcase (l, _, e) = formatLExpr l <+> text "->" $+$ (nest 2 $ formatExpr e) 123 | -- No guard 124 | 125 | formatLExpr :: LExpr -> Doc 126 | formatLExpr (Var ident) = formatIdent ident 127 | formatLExpr (Constr ident []) = formatIdent ident 128 | formatLExpr (Constr ident lExprs) = parens $ formatIdent ident <+> hsep (map formatLExprc lExprs) 129 | formatLExpr (Int i) = integer i 130 | formatLExpr (Tuple lExprs) = parens $ commaSep formatLExpr lExprs 131 | formatLExpr (List l) | nilTerm l = brackets $ commaSep formatLExpr $ tolist l 132 | formatLExpr (List l) = parens $ colonSep formatLExprc $ tolist l 133 | formatLExpr (App ident rev lExprs) = formatIdent ident <> formatRev rev <+> hsep (map formatLExprc lExprs) 134 | where 135 | formatRev True = text "" 136 | formatRev False = text "!" 137 | 138 | formatLExprc :: LExpr -> Doc 139 | formatLExprc (Var ident) = formatIdent ident 140 | formatLExprc (Constr ident []) = formatIdent ident 141 | formatLExprc (Constr ident lExprs) = parens $ formatIdent ident <+> hsep (map formatLExpr lExprs) 142 | formatLExprc (Int i) = integer i 143 | formatLExprc (Tuple lExprs) = parens $ commaSep formatLExpr lExprs 144 | formatLExprc (List l) | nilTerm l = brackets $ commaSep formatLExpr $ tolist l 145 | formatLExprc (List l) = parens $ colonSep formatLExpr $ tolist l 146 | formatLExprc (App ident rev lExprs) = parens $ formatIdent ident <> formatRev rev <+> hsep (map formatLExpr lExprs) 147 | where 148 | formatRev True = text "" 149 | formatRev False = text "!" 150 | 151 | 152 | tolist :: LExprList -> [LExpr] 153 | tolist (ListCons l ls) = l : (tolist ls) 154 | tolist (ListNil) = [] 155 | tolist (ListEnd l) = [l] 156 | 157 | nilTerm :: LExprList -> Bool 158 | nilTerm (ListCons _ list) = nilTerm list 159 | nilTerm ListNil = True 160 | nilTerm _ = False 161 | 162 | formatIdent :: Ident -> Doc 163 | formatIdent = text.identifier 164 | 165 | formatValue :: Value -> Doc 166 | formatValue (IntV i) = integer i 167 | formatValue (QbitV c) = text $ show c 168 | formatValue (TupleV values) = parens $ commaSep formatValue values 169 | formatValue (ListV values) = brackets $ commaSep formatValue values 170 | formatValue (ConstrV ident values) = parens $ text ident <+> (hsep (map formatValue values)) 171 | formatValue (FunV i) = text i 172 | 173 | 174 | commaSep :: (a -> Doc) -> [a] -> Doc 175 | commaSep f x = hcat $ intersperse (text ", ") $ map f x 176 | 177 | colonSep :: (a -> Doc) -> [a] -> Doc 178 | colonSep f x = hcat $ intersperse (text ":") $ map f x 179 | 180 | -------------------------------------------------------------------------------- /src/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- 3 | -- Module : TypeCheck 4 | -- Copyright : Michael Kirkedal Thomsen, 2017 5 | -- License : AllRightsReserved 6 | -- 7 | -- Maintainer : Michael Kirkedal Thomsen 8 | -- Stability : none? 9 | -- Portability : ? 10 | -- 11 | -- |Simple type check for RFun17 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module TypeCheck (typecheck) where 16 | 17 | import Ast 18 | import PrettyPrinter 19 | import qualified Data.Map as M 20 | 21 | import Control.Monad.State 22 | import Control.Monad.Reader 23 | import Control.Monad.Except 24 | 25 | -- import Data.List (intersperse) 26 | 27 | typecheck :: Program -> Maybe String 28 | typecheck p = catchTCError $ hts >> cfd >> ltc 29 | where 30 | hts = mapError hasTypeSignature p 31 | cfd = mapError checkFunctionDefinitions p 32 | ltc = mapError (checkFunc (fenvFromProgram p)) p 33 | -- Get function names and definitions 34 | -- Check each function 35 | -- Check first-match policy 36 | -- Check that value had correct type 37 | 38 | type TCError a = Either String a 39 | 40 | noTypeError :: TCError () 41 | noTypeError = return () 42 | 43 | catchTCError :: TCError () -> Maybe String 44 | catchTCError (Right _) = Nothing 45 | catchTCError (Left l ) = return l 46 | 47 | mapError :: (a -> TCError ()) -> [a] -> TCError () 48 | mapError f l = 49 | case (mapM f l) of 50 | (Right _) -> return () 51 | (Left e ) -> fail e 52 | 53 | maybeError :: Maybe a -> a 54 | maybeError Nothing = error "Cannot be nothing" 55 | maybeError (Just x) = x 56 | 57 | 58 | -- Check names 59 | 60 | -- |Check Function types and definitions 61 | checkFunctionDefinitions :: Func -> TCError () 62 | checkFunctionDefinitions func@(Func _ _ _) = 63 | mapError checkFunctionClause $ funcClause func 64 | where 65 | checkFunctionClause clause | length (clauseParam clause) /= length typeDefList = fail $ errorDifferentNumberArgs (clauseIdent clause) (funcName func) 66 | checkFunctionClause clause = mapError (\(x,y) -> checkTypeMatchLExpr (clauseIdent clause) x y) (zip typeDefList (clauseParam clause)) 67 | typeDefList = typeDefList_ $ funcTypesig func 68 | typeDefList_ Nothing = [] 69 | typeDefList_ (Just (TypeSig ancT leftT _)) = ancT ++ [leftT] 70 | checkFunctionDefinitions (DataType _ _) = noTypeError 71 | -- TypeSig [BType] BType 72 | 73 | -- |Check if all functions have type signatures 74 | hasTypeSignature :: Func -> TCError () 75 | hasTypeSignature (Func i _ _) | (identifier i) == "eq" = fail $ "eq is a reserved function name." 76 | hasTypeSignature (Func i _ _) | (identifier i) == "id" = fail $ "id is a reserved function name." 77 | hasTypeSignature func@(Func _ _ _) = 78 | case (funcTypesig func) of 79 | (Just _) -> noTypeError 80 | Nothing -> fail $ errorNoTypeSignature (funcName func) 81 | hasTypeSignature (DataType i _) | (identifier i) == "EQ" = fail $ "EQ is a reserved datatype name." 82 | hasTypeSignature (DataType _ _) = noTypeError 83 | 84 | 85 | --------- 86 | 87 | checkTypeMatchLExpr :: Ident -> BType -> LExpr -> TCError () 88 | checkTypeMatchLExpr i t le = 89 | case getLExprType le of 90 | Nothing -> fail $ errorTypeMatch i t le 91 | (Just leType) -> 92 | case bTypeUnifies t leType of 93 | True -> noTypeError 94 | False -> fail $ errorTypeMatch i t le 95 | 96 | typeEquality :: TypeSig -> TypeSig -> Bool 97 | typeEquality (TypeSig ancT1 leftT1 rightT1) (TypeSig ancT2 leftT2 rightT2) | length ancT1 == length ancT2 = 98 | and $ zipWith bTypeUnifies (leftT1:rightT1:ancT1) (leftT2:rightT2:ancT2) 99 | typeEquality _ _ = False 100 | 101 | bTypeUnifies :: BType -> BType -> Bool 102 | -- bTypeUnifies NatT NatT = True 103 | bTypeUnifies (DataT i1) (DataT i2) | identifier i1 == identifier i2 = True 104 | bTypeUnifies (ListT t1) (ListT t2) = bTypeUnifies t1 t2 105 | bTypeUnifies (ProdT t1) (ProdT t2) | length t1 == length t2 = and $ zipWith bTypeUnifies t1 t2 106 | bTypeUnifies (SumT t1) (SumT t2) | length t1 == length t2 = and $ zipWith bTypeUnifies t1 t2 107 | bTypeUnifies (FunT t1) (FunT t2) = typeEquality t1 t2 108 | bTypeUnifies (VarT i1) (VarT i2) | identifier i1 == identifier i2 = True 109 | bTypeUnifies AnyT _ = True 110 | bTypeUnifies _ AnyT = True 111 | bTypeUnifies _ _ = False 112 | 113 | 114 | 115 | typeUnification :: TypeSig -> TypeSig -> Maybe TypeSig 116 | typeUnification (TypeSig ancTs1 leftT1 rightT1) (TypeSig ancTs2 leftT2 rightT2) = 117 | do ancT <- sequence $ zipWith bTypeUnification ancTs1 ancTs2 118 | leftT <- bTypeUnification leftT1 leftT2 119 | rightT <- bTypeUnification rightT1 rightT2 120 | return $ TypeSig ancT leftT rightT 121 | 122 | bTypeUnification :: BType -> BType -> Maybe BType 123 | bTypeUnification t@(DataT i1) (DataT i2) | identifier i1 == identifier i2 = Just t 124 | bTypeUnification (ListT t1) (ListT t2) = 125 | case bTypeUnification t1 t2 of 126 | Nothing -> Nothing 127 | (Just t) -> Just $ ListT t 128 | bTypeUnification (ProdT t1) (ProdT t2) | length t1 == length t2 = 129 | case sequence $ zipWith bTypeUnification t1 t2 of 130 | Nothing -> Nothing 131 | (Just t) -> Just $ ProdT t 132 | -- bTypeUnification (SumT t1) (SumT t2) | length t1 == length t2 = and $ zipWith bTypeUnification t1 t2 133 | bTypeUnification (FunT t1) (FunT t2) = 134 | case typeUnification t1 t2 of 135 | Nothing -> Nothing 136 | (Just t) -> Just $ FunT t 137 | bTypeUnification t@(VarT _) (VarT _) = Just t 138 | bTypeUnification (VarT _) t = Just t 139 | bTypeUnification t (VarT _) = Just t 140 | -- bTypeUnification t@(VarT i1) (VarT i2) | identifier i1 == identifier i2 = Just t 141 | bTypeUnification AnyT t = Just t 142 | bTypeUnification t AnyT = Just t 143 | bTypeUnification _ _ = Nothing 144 | 145 | getLExprType :: LExpr -> Maybe BType 146 | getLExprType (Var _) = Just AnyT -- Variable can be any type 147 | getLExprType (Int _) = Just $ DataT $ makeIdent "Nat" 148 | -- getLExprType (Constr i []) | (identifier i == "Z") = Just NatT 149 | -- getLExprType (Constr i [lExpr]) | (identifier i == "S") = (getLExprType lExpr) >>= (bTypeUnification NatT) 150 | getLExprType (Constr _ _) = Just AnyT -- I need function Env 151 | getLExprType (Tuple lExprs) = (sequence $ map getLExprType lExprs) >>= (\x -> Just $ ProdT x) 152 | -- DataT Ident -- ^ Constructor term 153 | getLExprType (List lExprList) = getListLExprType lExprList >>= (\t -> return $ ListT t) 154 | where 155 | getListLExprType (ListCons lExpr lExprL) = 156 | do t1 <- getLExprType lExpr 157 | t2 <- getListLExprType lExprL 158 | bTypeUnification t1 t2 159 | getListLExprType (ListEnd lExpr) = getLExprType lExpr 160 | getListLExprType (ListNil) = Just AnyT 161 | getLExprType (App _ _ _) = Just AnyT 162 | 163 | -- data BType = NatT | AnyT Ident | ListT BType | ProdT [BType] | SumT [BType] | FunT TypeSig 164 | -- deriving (Eq, Show) 165 | 166 | -- Check Linearity 167 | -- Check Ancillae 168 | 169 | type FunEnv = M.Map String Func 170 | 171 | fenvFromProgram :: Program -> FunEnv 172 | fenvFromProgram p = M.fromList $ (eqTD:(map f p)) 173 | where f func@(Func _ _ _) = ((identifier.funcName) func, func) 174 | f dataT@(DataType _ _) = ((identifier.dataName) dataT, dataT) 175 | eqTD = ("EQ", DataType (makeIdent "EQ") (M.fromList [ 176 | ("Eq", (makeIdent "Eq", [])), 177 | ("Neq", (makeIdent "Neq", [AnyT]))]) ) 178 | 179 | data VarType = Ancillae BType | Live BType | Killed 180 | deriving (Eq, Show) 181 | 182 | type Vars = M.Map String VarType 183 | 184 | 185 | newtype TC a = E { runE :: StateT Vars (ReaderT FunEnv (Except String)) a } 186 | deriving (Applicative, Functor, Monad, MonadReader FunEnv, MonadState Vars, MonadError String) 187 | 188 | runTC :: TC a -> Vars -> FunEnv -> (TCError (a, Vars)) 189 | runTC eval vars fenv = runExcept $ runReaderT (runStateT (runE eval) vars) fenv 190 | 191 | addLive :: Ident -> BType -> TC BType 192 | addLive i btype = 193 | do b <- varExist i 194 | when b $ throwError $ errorAddExistingVariable i --- Can check if it is alive of dead 195 | modify (\x -> M.insert (identifier i) (Live btype) x) 196 | return btype 197 | 198 | addAncillae :: Ident -> BType -> TC BType 199 | addAncillae i btype = 200 | do b <- varExist i 201 | when b $ throwError $ errorAddExistingVariable i --- Can check if it is alive of dead 202 | modify (\x -> M.insert (identifier i) (Ancillae btype) x) 203 | return btype 204 | 205 | killLive :: Ident -> BType -> TC BType 206 | killLive i btype = 207 | do c <- get 208 | case M.lookup (identifier i) c of 209 | Nothing -> throwError $ errorUseOfNonExistingVariable i 210 | (Just Killed) -> throwError $ errorUseKilledVariable i 211 | (Just (Ancillae _)) -> throwError $ errorUseAncillaVariable i 212 | (Just (Live t)) -> 213 | case bTypeUnification btype t of 214 | Nothing -> throwError $ errorDifferentTypes i t btype 215 | (Just ut) -> return ut 216 | 217 | checkAncillae :: Ident -> BType -> TC BType 218 | checkAncillae i btype = 219 | do c <- get 220 | case M.lookup (identifier i) c of 221 | Nothing -> 222 | do b <- funExist i 223 | unless b $ throwError $ errorUseOfNonExistingVariable i 224 | -- t <- funTypeSig i 225 | return btype 226 | (Just Killed) -> throwError $ errorUseKilledVariable i 227 | (Just (Ancillae t)) -> 228 | case bTypeUnification btype t of 229 | Nothing -> throwError $ errorDifferentTypes i t btype 230 | (Just ut) -> return ut 231 | (Just (Live t)) -> 232 | case bTypeUnification btype t of 233 | Nothing -> throwError $ errorDifferentTypes i t btype 234 | (Just ut) -> return ut 235 | 236 | 237 | varExist :: Ident -> TC Bool 238 | varExist i = 239 | do v <- get 240 | return $ M.member (identifier i) v 241 | 242 | funExist :: Ident -> TC Bool 243 | funExist i = 244 | do fenv <- ask 245 | return $ M.member (identifier i) fenv 246 | 247 | funTypeSig :: Ident -> TC TypeSig 248 | funTypeSig i | (identifier i) == "eq" = return $ TypeSig [VarT i] (VarT i) (DataT $ makeIdent "EQ") 249 | funTypeSig i = 250 | do fenv <- ask 251 | case M.lookup (identifier i) fenv of 252 | Nothing -> 253 | do v <- get 254 | case M.lookup (identifier i) v of 255 | Nothing -> throwError $ errorUseOfNonExistingFunction i 256 | Just (Ancillae (FunT sig)) -> return sig 257 | _ -> throwError $ errorUseOfNonExistingFunction i 258 | Just (Func _ s _) -> return $ maybeError s 259 | _ -> throwError $ errorUseOfNonExistingFunction i 260 | 261 | dataTypeDef :: Ident -> Ident -> TC [BType] 262 | dataTypeDef i c = 263 | do fenv <- ask 264 | case M.lookup (identifier i) fenv of 265 | Nothing -> throwError $ errorUseOfNonExistingTypeDefinition i 266 | Just (DataType _ s) -> 267 | case M.lookup (identifier c) s of 268 | Nothing -> throwError $ errorUseOfNonExistingDataConstructor c i 269 | Just td -> return $ snd td 270 | _ -> throwError $ errorUseOfNonExistingDataConstructor c i 271 | 272 | checkFunc :: FunEnv -> Func -> TCError () 273 | checkFunc fe f@(Func _ _ _) = mapError (\x -> checkClause x (maybeError $ funcTypesig f) fe) $ funcClause f 274 | checkFunc _ (DataType _ _) = noTypeError 275 | 276 | 277 | -- We ignore Guards at the moment 278 | checkClause :: Clause -> TypeSig -> FunEnv -> TCError () 279 | checkClause c (TypeSig ancT inT outT) fe = 280 | case runTC (eval (clauseParam c) (ancT ++ [inT])) (M.empty) fe of 281 | Left e -> fail e 282 | Right _ -> noTypeError 283 | where 284 | eval [x] [y] = (checkLExpr addLive x y) >> (checkExpr (clauseBody c) outT) 285 | eval (x:xs) (y:ys) = (checkLExpr addAncillae x y) >> (eval xs ys) 286 | eval _ _ = error "...." 287 | 288 | checkExpr :: Expr -> BType -> TC () 289 | checkExpr (LeftE lExpr) btype = checkLExpr killLive lExpr btype >> return () 290 | checkExpr (LetIn leftLE rightLE expr) btype = 291 | do t <- checkLExpr killLive rightLE AnyT 292 | checkLExpr addLive leftLE t 293 | checkExpr expr btype 294 | checkExpr (CaseOf lExpr cases) btype = -- [(LExpr, Guard, Expr)] -- ^ Case-of expression 295 | do t <- checkLExpr killLive lExpr AnyT 296 | mapM_ (testCase t) cases 297 | where 298 | testCase bt (lE, _, ex) = 299 | do v <- get 300 | checkLExpr addLive lE bt 301 | checkExpr ex btype 302 | put v 303 | 304 | 305 | checkLExpr :: (Ident -> BType -> TC BType) -> LExpr -> BType -> TC BType 306 | checkLExpr addFun (Var ident) btype = addFun ident btype -- Variable can be any type 307 | -- Integers 308 | checkLExpr _ (Int _) btype | bTypeUnifies btype (DataT $ makeIdent "Nat") = return $ DataT $ makeIdent "Nat" 309 | checkLExpr _ lExpr@(Int _) t = throwError $ errorLExprUnification lExpr t 310 | -- checkLExpr _ (Constr i []) btype | (identifier i == "Z"), bTypeUnifies btype NatT = return NatT 311 | -- checkLExpr addFun (Constr i [lExpr]) btype | (identifier i == "S") = checkLExpr addFun lExpr btype 312 | checkLExpr addFun lExpr@(Constr i lExprs) t@(DataT typeName) = 313 | do dd <- dataTypeDef typeName i 314 | when ((length dd) /= length lExprs) $ throwError $ errorLExprUnification lExpr t 315 | sequence $ zipWith (checkLExpr addFun) (lExprs) dd 316 | return $ DataT typeName 317 | 318 | checkLExpr addFun (Tuple lExprs) (ProdT btypes) | length lExprs == length btypes = 319 | do types <- sequence $ zipWith (checkLExpr addFun) lExprs btypes 320 | return $ ProdT types 321 | checkLExpr _ lExpr@(Tuple _) t = throwError $ errorLExprUnification lExpr t 322 | checkLExpr addFun le@(List lExprList) tp@(ListT btype) = getListLExprType lExprList 323 | where 324 | getListLExprType (ListCons lExpr lExprL) = 325 | do t1 <- checkLExpr addFun lExpr btype 326 | t2 <- getListLExprType lExprL 327 | case bTypeUnification (ListT t1) t2 of 328 | Nothing -> throwError $ errorLExprUnification le tp 329 | Just t -> return t 330 | getListLExprType (ListEnd lExpr) = checkLExpr addFun lExpr (ListT btype) 331 | getListLExprType ListNil = return tp 332 | checkLExpr _ lExpr@(List _) t = throwError $ errorLExprUnification lExpr t 333 | checkLExpr addFun (App ident True lExprs) _ = 334 | do (TypeSig ancTs updT retT) <- funTypeSig ident 335 | -- when ((length ancTs) + 1 /= length lExprs) $ throwError $ errorDifferentNumberArgsApp ident (TypeSig ancTs updT retT) lExprs 336 | sequence $ zipWith (checkLExpr checkAncillae) (init lExprs) ancTs 337 | checkLExpr addFun (last lExprs) updT 338 | return retT 339 | checkLExpr addFun (App ident False lExprs) _ = 340 | do (TypeSig ancTs updT retT) <- funTypeSig ident 341 | -- when ((length ancTs) + 1 /= length lExprs) $ throwError $ errorDifferentNumberArgsApp ident (TypeSig ancTs updT retT) lExprs 342 | sequence $ zipWith (checkLExpr checkAncillae) (init lExprs) ancTs 343 | checkLExpr addFun (last lExprs) retT 344 | return updT 345 | checkLExpr _ lExpr t = throwError $ errorLExprUnification lExpr t 346 | 347 | 348 | 349 | 350 | errorFirst :: Ident -> String 351 | errorFirst i_def = 352 | "In " ++ ppIdentFile i_def ++ ", " ++ ppIdentPos i_def ++ "\n " 353 | 354 | errorUseKilledVariable :: Ident -> String 355 | errorUseKilledVariable i = 356 | errorFirst i ++ "the variable " ++ ppIdent i ++ " which is trying to be has already been used." 357 | 358 | errorUseAncillaVariable :: Ident -> String 359 | errorUseAncillaVariable i = 360 | errorFirst i ++ "the variable " ++ ppIdent i ++ " which is trying to be has ancillae type." 361 | 362 | errorAddExistingVariable :: Ident -> String 363 | errorAddExistingVariable i = 364 | errorFirst i ++ "the variable " ++ ppIdent i ++ " has already been defined." 365 | 366 | errorUseOfNonExistingVariable :: Ident -> String 367 | errorUseOfNonExistingVariable i = 368 | errorFirst i ++ "the variable " ++ ppIdent i ++ " is undefined." 369 | 370 | errorUseOfNonExistingFunction :: Ident -> String 371 | errorUseOfNonExistingFunction i = 372 | errorFirst i ++ "the function " ++ ppIdent i ++ " is undefined." 373 | 374 | errorUseOfNonExistingDataConstructor :: Ident -> Ident -> String 375 | errorUseOfNonExistingDataConstructor i t = 376 | errorFirst i ++ "the constructor " ++ ppIdent i ++ " in type definition " ++ ppIdent t ++ " is undefined." 377 | 378 | errorUseOfNonExistingTypeDefinition :: Ident -> String 379 | errorUseOfNonExistingTypeDefinition i = 380 | errorFirst i ++ "the type definition " ++ ppIdent i ++ " is undefined." 381 | 382 | errorLExprUnification :: LExpr -> BType -> String 383 | errorLExprUnification le a_type = 384 | "The left-expression\n " ++ ppLExpr le ++ "\ncannot be unified with type\n " ++ ppBType a_type ++ "\n" 385 | 386 | 387 | errorDifferentTypes :: Ident -> BType -> BType -> String 388 | errorDifferentTypes i_def i_type a_type = 389 | errorFirst i_def ++ "the variable " ++ ppIdent i_def ++ " of type\n " ++ ppBType i_type ++ "\n" ++ 390 | "does not have expected type\n " ++ ppBType a_type 391 | 392 | errorDifferentNumberArgsApp :: Ident -> TypeSig -> [LExpr] -> String 393 | errorDifferentNumberArgsApp i_def i_sig args = 394 | errorFirst i_def ++ "the function \n " ++ ppIdent i_def ++ " :: " ++ ppTypeSig i_sig ++ "\n" ++ 395 | "is provided with " ++ (show $ length args) ++ " arguments.\n" 396 | 397 | errorTypeMatch :: Ident -> BType -> LExpr -> String 398 | errorTypeMatch i_def btype lExpr = 399 | case getLExprType lExpr of 400 | Nothing -> "errorTypeMatch" 401 | (Just t) -> 402 | "In " ++ ppIdentFile i_def ++ " function " ++ ppIdent i_def ++ " (" ++ ppIdentLine i_def ++ ") " ++ 403 | "the type of left-expression \n " ++ ppLExpr lExpr ++ "\nof type\n " ++ (ppBType t) ++ 404 | "\ndoes not match type signature \n " ++ ppBType btype ++ "\n" 405 | 406 | errorDifferentNumberArgs :: Ident -> Ident -> String 407 | errorDifferentNumberArgs i_def i_sig = 408 | "In " ++ ppIdentFile i_def ++ " function " ++ ppIdent i_def ++ " (" ++ ppIdentLine i_def ++ 409 | ") has different number of arguments than in type signature (" ++ ppIdentLine i_sig ++ ").\n" 410 | 411 | errorNoTypeSignature :: Ident -> String 412 | errorNoTypeSignature i = 413 | "In " ++ ppIdentFile i ++ " function " ++ ppIdent i ++ " (" ++ ppIdentPos i ++ ") has not type signature.\n" ++ 414 | " Type inference is not supported yet." 415 | --------------------------------------------------------------------------------