├── tests ├── test10.txt ├── test16.txt ├── test02.txt ├── test05.txt ├── test27.txt ├── test12.txt ├── test25.txt ├── test17.txt ├── test23.txt ├── test01.txt ├── test03.txt ├── test11.txt ├── test04.txt ├── test15.txt ├── test26.txt ├── test13.txt ├── test22.txt ├── test00.txt ├── test21.txt ├── test14.txt ├── test24.txt ├── test28.txt ├── test06.txt ├── test08.txt ├── test29.txt ├── test20.txt ├── test09.txt ├── test19.txt ├── test07.txt └── test18.txt ├── .gitignore ├── project22-23.pdf ├── src ├── Makefile ├── TestMain.hs ├── Types.hs ├── Intensional.hs ├── Transform.hs └── Parser.hs ├── pdfs ├── efficient_intensional.pdf ├── lazy_typed_fp_dataflow.pdf └── first_order_functional_to_intensional.pdf ├── Makefile ├── README.md └── test_script.py /tests/test10.txt: -------------------------------------------------------------------------------- 1 | result = f() + 5; 2 | f() = 3; 3 | -------------------------------------------------------------------------------- /tests/test16.txt: -------------------------------------------------------------------------------- 1 | result = f(5); 2 | f(x) = x + 1; 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode 2 | .DS_Store 3 | dist-newstyle 4 | -------------------------------------------------------------------------------- /tests/test02.txt: -------------------------------------------------------------------------------- 1 | result = f(f(f(1))); 2 | f(x) = x + 2; -------------------------------------------------------------------------------- /tests/test05.txt: -------------------------------------------------------------------------------- 1 | result = f(3, 5); 2 | f(x,y) = x - (2 * y); -------------------------------------------------------------------------------- /tests/test27.txt: -------------------------------------------------------------------------------- 1 | result = False || f(True); 2 | f(n) = True; -------------------------------------------------------------------------------- /tests/test12.txt: -------------------------------------------------------------------------------- 1 | result = f() || g(); 2 | f() = True; 3 | g() = g(); 4 | -------------------------------------------------------------------------------- /tests/test25.txt: -------------------------------------------------------------------------------- 1 | result = f() + 5 - g(2); 2 | f() = 3; 3 | g(y) = (2 * y); -------------------------------------------------------------------------------- /tests/test17.txt: -------------------------------------------------------------------------------- 1 | result = f() + g() + f(); 2 | f() = g(); 3 | g() = 2; 4 | -------------------------------------------------------------------------------- /tests/test23.txt: -------------------------------------------------------------------------------- 1 | result = f(f(f(4))); 2 | f(x) = g(x+1); 3 | g(y) = y; -------------------------------------------------------------------------------- /tests/test01.txt: -------------------------------------------------------------------------------- 1 | result = g(2) + f(5) + f(3); 2 | g(n) = f(n); 3 | f(x) = x + 2; -------------------------------------------------------------------------------- /tests/test03.txt: -------------------------------------------------------------------------------- 1 | result = f(f(1) + f(2) + g(3)); 2 | g(n) = f(n); 3 | f(x) = x + 2; -------------------------------------------------------------------------------- /tests/test11.txt: -------------------------------------------------------------------------------- 1 | result = f(f(4)) + f(5); 2 | f(x) = g(x + 1); 3 | g(y) = y; 4 | -------------------------------------------------------------------------------- /tests/test04.txt: -------------------------------------------------------------------------------- 1 | result = f(1) + f(2) + g(3); 2 | g(n) = f(4) + f(5); 3 | f(x) = x + 2; -------------------------------------------------------------------------------- /tests/test15.txt: -------------------------------------------------------------------------------- 1 | result = 2 + if True then 1 + if 2 > 3 then -3 else 1 + 5 else 1; 2 | -------------------------------------------------------------------------------- /tests/test26.txt: -------------------------------------------------------------------------------- 1 | result = f(f(f(1))) + h(3,4); 2 | h(n,k) = (3 * n) + k; 3 | f(x) = x + 2; -------------------------------------------------------------------------------- /project22-23.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/georgesittas/minihaskell-compiler/HEAD/project22-23.pdf -------------------------------------------------------------------------------- /tests/test13.txt: -------------------------------------------------------------------------------- 1 | result = f(f(f(f(4)))) + f(5); 2 | f(x) = x + g(x,0); 3 | g(y,z) = z; 4 | 5 | -------------------------------------------------------------------------------- /tests/test22.txt: -------------------------------------------------------------------------------- 1 | result = (g(3,4) || g(5,6) || g(7,8)) && f(); 2 | g(x,y) = True; 3 | f() = False; -------------------------------------------------------------------------------- /tests/test00.txt: -------------------------------------------------------------------------------- 1 | result = fib(4); 2 | 3 | fib(n) = if n == 1 || n == 0 then 1 else fib(n-1) + fib(n-2); 4 | -------------------------------------------------------------------------------- /tests/test21.txt: -------------------------------------------------------------------------------- 1 | result = f(2,3) + 10 + g(g(4)); 2 | f(x,y) = if (x >= 3) then 5 else y; 3 | g(z) = 11 * z; -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | compile: 2 | ghc --make TestMain.hs -package mtl 3 | 4 | clean: 5 | rm -f *.hi *.o TestMain 6 | -------------------------------------------------------------------------------- /tests/test14.txt: -------------------------------------------------------------------------------- 1 | result = if f(5,-4) then g(1) else h(g(1)); 2 | f(x,y) = x + 12 > y; 3 | g(z) = z * z; 4 | h(n) = n / (n-2); -------------------------------------------------------------------------------- /pdfs/efficient_intensional.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/georgesittas/minihaskell-compiler/HEAD/pdfs/efficient_intensional.pdf -------------------------------------------------------------------------------- /pdfs/lazy_typed_fp_dataflow.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/georgesittas/minihaskell-compiler/HEAD/pdfs/lazy_typed_fp_dataflow.pdf -------------------------------------------------------------------------------- /tests/test24.txt: -------------------------------------------------------------------------------- 1 | result = g(f(3, 5) * (-2)) + h(-1); 2 | f(x,y) = x - (2 * y); 3 | g(z) = (-3 * z); 4 | h(t) = if (t < 0) then 1 else 0; -------------------------------------------------------------------------------- /tests/test28.txt: -------------------------------------------------------------------------------- 1 | result = if ( (f(False) || y(5124)) /= True ) then False else f( True ); 2 | f(x) = not (True && False); 3 | y(z) = False; -------------------------------------------------------------------------------- /tests/test06.txt: -------------------------------------------------------------------------------- 1 | result = f(f(f(2 + g(3 - f(1)))) - f(g(f(2)))); 2 | f(x) = if x <= 1 then g(3 + 5 * 2) else f(x - g(1)); 3 | g(y) = y + 2; 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | compile: 2 | $(MAKE) -C ./src/ compile 3 | 4 | tests: compile 5 | python test_script.py 6 | 7 | clean: 8 | $(MAKE) -C ./src/ clean 9 | -------------------------------------------------------------------------------- /tests/test08.txt: -------------------------------------------------------------------------------- 1 | result = fib(10) + fact(8); 2 | fib(n) = if (n<=1) then 1 else fib(n-1) + fib(n-2); 3 | fact(m) = if (m<=1) then 1 else m*fact(m-1); 4 | -------------------------------------------------------------------------------- /tests/test29.txt: -------------------------------------------------------------------------------- 1 | result = f(1, 1, 8) + ( g() - 7 ) + f(1,2,8); 2 | f(x,y,z) = (3 * x) - (2 * y) + z; 3 | h(k) = if (k < 0) then 0 else k; 4 | g() = 7; -------------------------------------------------------------------------------- /pdfs/first_order_functional_to_intensional.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/georgesittas/minihaskell-compiler/HEAD/pdfs/first_order_functional_to_intensional.pdf -------------------------------------------------------------------------------- /tests/test20.txt: -------------------------------------------------------------------------------- 1 | result = not (f(True, False) || g(1,2) < 2); 2 | f(x,y) = x || (y && not x); 3 | g(z,w) = if z+1 <= w then (if z == 0 then 1 else 0) else 2; 4 | -------------------------------------------------------------------------------- /tests/test09.txt: -------------------------------------------------------------------------------- 1 | result = ackermann(4,0); 2 | ackermann (n,m) = if n == 0 then m+1 else if m == 0 then ackermann (n-1,1) else ackermann (n-1, ackermann (n, m-1)); 3 | -------------------------------------------------------------------------------- /tests/test19.txt: -------------------------------------------------------------------------------- 1 | result = if not (is_negative(f(1, 2, 3)) || not (is_negative(f(1,-1,8)))) then True else False; 2 | f(x, y, z) = x + y * z; 3 | is_negative(n) = if not (n < 0) then True else False; 4 | -------------------------------------------------------------------------------- /tests/test07.txt: -------------------------------------------------------------------------------- 1 | result = f(f(1 + f(2 - f(5, 1, 2), 5+3, 3), 5, 1), f(3, 3, 1), f(g(1), g(2), g(f(1, 2, 3)))); 2 | f(x, y, z) = if x <= 10 then g(3 + 5 * 2) else f(x - g(1), x+1, 5); 3 | g(w) = w + 2; 4 | -------------------------------------------------------------------------------- /tests/test18.txt: -------------------------------------------------------------------------------- 1 | result = f(f(1) + f(2) + g((h(3,f(g(4+c(13,3,5))))))); 2 | g(n) = f(n+10); 3 | f(x) = x + 2; 4 | h(z,y) = f(z) + f(y)*g(z*y+f(8)*5*g(9)); 5 | c(a,b,l) = if a < 10 then b*f(f(f(f(g(h(1,g(l))))))) else c(a-1,b*f(7),l+1); 6 | -------------------------------------------------------------------------------- /src/TestMain.hs: -------------------------------------------------------------------------------- 1 | {- Usage: ./a.out < input.txt -} 2 | 3 | import Types 4 | import Parser (programParser) 5 | import Transform (transform) 6 | import Intensional (eval) 7 | 8 | main :: IO() 9 | main = do 10 | contents <- getContents 11 | case programParser contents of 12 | Left err -> error ("Parse Error") 13 | Right fp -> 14 | case eval (transform fp) of 15 | INum n -> print n 16 | IBool b -> print b 17 | _ -> error ("Runtime Error") 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## MiniHaskell Compiler 2 | 3 | This is a comprehensive implementation of a compiler and interpreter for MiniHaskell, a small subset of Haskell. The MiniHaskell code is compiled into an intermediate representation called _intensional code_, which is then used as the source language for the execution process. 4 | 5 | The goal for this project was to design, implement and grade the final assignment for the [Programming Language Principles](https://cgi.di.uoa.gr/~prondo/LANGUAGES/languages.html) course, which is taught by prof. [Panagiotis Rontogiannis](https://cgi.di.uoa.gr/~prondo/) in [DiT](https://www.di.uoa.gr/) (UoA). The [assignment description](https://github.com/GeorgeSittas/minihaskell-compiler/blob/main/project22-23.pdf) is also included (in Greek). 6 | 7 | ### Intensional Code 8 | 9 | Intensional code is a dataflow programming language inspired by [Lucid](https://en.wikipedia.org/wiki/Lucid_(programming_language)), and has been described extensively in the [paper](https://www.cambridge.org/core/services/aop-cambridge-core/content/view/CDA5800533BC35832DDC9587E15EFCE0/S0956796897002633a.pdf/firstorder_functional_languages_and_intensional_logic.pdf) "First-order functional languages and intensional logic", by P. Rontogiannis, W. W. Wadge. 10 | 11 | ### Usage 12 | 13 | ```bash 14 | # Install Haskell via GHCup 15 | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh 16 | 17 | # Install dependencies 18 | cabal install --lib parsec 19 | cabal install --lib pretty-simple 20 | 21 | # Expose packages so that linking works as expected 22 | ghc-pkg expose parsec 23 | ghc-pkg expose pretty 24 | ghc-pkg expose mtl 25 | 26 | # Compile the project 27 | make 28 | 29 | # Run the test suite 30 | make tests 31 | 32 | # Remove all generated files 33 | make clean 34 | ``` 35 | 36 | ### Note 37 | 38 | As described in the related [articles](https://github.com/GeorgeSittas/minihaskell-compiler/tree/main/pdfs), this implementation could be made a lot more efficient. However, this was outside the project's scope, and hence the interpreter is expected to be rather slow. A faster implementation in Rust can be found [here](https://github.com/nikos-alexandris/ic). 39 | 40 | ### Issues 41 | 42 | The [test suite](https://github.com/GeorgeSittas/minihaskell-compiler/tree/main/tests) is certainly not exhaustive, so please consider [creating an issue](https://github.com/GeorgeSittas/minihaskell-compiler/issues/new) if you find a bug. 43 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | {- Recommended type signatures for functions "transform" and "eval": 4 | 5 | -- Transforms a MiniHaskell program into an intensional one. 6 | transform :: FProgram -> IProgram 7 | 8 | -- Evaluates an intensional program and returns the resulting expression. 9 | eval :: IProgram -> IExpr 10 | -} 11 | 12 | {- Functional Types -} 13 | 14 | -- AST representation of the source language (a small subset of Haskell). 15 | -- FExpr contains the AST representation of the expression assigned in the "result" function. 16 | -- [FDefinition] contains the AST representation of every other function definition. 17 | type FProgram = (FExpr, [FDefinition]) 18 | 19 | -- FDefinition consists of the following triplet: 20 | -- (Function Name, [Typical Parameters], AST Representation of Assigned Expression) 21 | -- Example: the function definition "foo(x, y) = x + y" is parsed into 22 | -- ("foo", ["x", "y"], (FBinaryOp Plus (FVar "x") (FVar "y")). 23 | type FDefinition = (String, [String], FExpr) 24 | 25 | data FExpr 26 | = FVar String 27 | | FNum Int 28 | | FBool Bool 29 | | FParens FExpr 30 | | FIfThenElse FExpr FExpr FExpr 31 | | FCall String [FExpr] 32 | | FCompOp OpCompare FExpr FExpr 33 | | FBinaryOp OpBinary FExpr FExpr 34 | | FBooleanOp OpBool FExpr FExpr 35 | | FUnaryOp OpUnary FExpr 36 | deriving (Eq, Show) 37 | 38 | {- Intensional Types -} 39 | 40 | -- AST representation of the intermediate (Intensional) language. 41 | type IProgram = [IDefinition] 42 | 43 | -- IDefinition consists of the pair: 44 | -- (Function Name, AST Representation of Intensional Expression) 45 | -- Example: the function definition "foo = x + y" is parsed into 46 | -- ("foo", (IBinaryOp Plus (IVar "x") (IVar "y")). 47 | type IDefinition = (String, IExpr) 48 | 49 | -- IEnv represents the "tags" environment variable to be used by the Intensional evaluator. 50 | type IEnv = [Int] 51 | 52 | data IExpr 53 | = IVar String 54 | | INum Int 55 | | IBool Bool 56 | | IParens IExpr 57 | | IIfThenElse IExpr IExpr IExpr 58 | | ICall Int String 59 | | IActuals [IExpr] 60 | | ICompOp OpCompare IExpr IExpr 61 | | IBinaryOp OpBinary IExpr IExpr 62 | | IBooleanOp OpBool IExpr IExpr 63 | | IUnaryOp OpUnary IExpr 64 | deriving (Eq, Show) 65 | 66 | {- Common Types -} 67 | 68 | data OpBinary = Plus | Mult | Minus | Div 69 | deriving (Eq, Show) 70 | 71 | data OpCompare = LtEq | Lt | GtEq | Gt | Eq | Neq 72 | deriving (Eq, Show) 73 | 74 | data OpBool = And | Or 75 | deriving (Eq, Show) 76 | 77 | data OpUnary = Positive | Negative | Not 78 | deriving (Eq, Show) 79 | -------------------------------------------------------------------------------- /src/Intensional.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Intensional where 4 | 5 | import Types 6 | 7 | eval :: IProgram -> IExpr 8 | eval p = eval' p [] result 9 | where 10 | result = case lookup "result" p of 11 | Just e -> e 12 | Nothing -> error "no 'result' definition in program" 13 | 14 | eval' :: IProgram -> IEnv -> IExpr -> IExpr 15 | eval' p ts (IVar x) = 16 | case lookup x p of 17 | Just e -> eval' p ts e 18 | Nothing -> error ("[Runtime error]: unbound variable '" ++ x ++ "'") 19 | eval' _ _ (INum n) = 20 | INum n 21 | eval' _ _ (IBool b) = 22 | IBool b 23 | eval' p ts (IParens e) = 24 | eval' p ts e 25 | eval' p ts (IIfThenElse c t f) = 26 | case eval' p ts c of 27 | IBool True -> eval' p ts t 28 | IBool False -> eval' p ts f 29 | _ -> error "[Runtime error]: condition of 'if' is not a boolean" 30 | eval' p ts (ICall t n) = 31 | case lookup n p of 32 | Just e -> eval' p (t : ts) e 33 | Nothing -> error ("[Runtime error]: unbound function '" ++ n ++ "'") 34 | eval' p ts (IActuals es) = 35 | case ts of 36 | [] -> error "[Runtime error]: actuals called with empty environment" 37 | t : ts' -> eval' p ts' (es !! t) 38 | eval' p ts (ICompOp op e0 e1) = 39 | case (eval' p ts e0, eval' p ts e1) of 40 | (INum n0, INum n1) -> 41 | IBool $ case op of 42 | LtEq -> n0 <= n1 43 | Lt -> n0 < n1 44 | GtEq -> n0 >= n1 45 | Gt -> n0 > n1 46 | Eq -> n0 == n1 47 | Neq -> n0 /= n1 48 | (IBool b0, IBool b1) -> 49 | IBool $ case op of 50 | Eq -> b0 == b1 51 | Neq -> b0 /= b1 52 | _ -> error "[Runtime error]: unsupported for booleans" 53 | _ -> error "[Runtime error]: wrong comparison" 54 | eval' p ts (IBinaryOp op e0 e1) = 55 | case (eval' p ts e0, eval' p ts e1) of 56 | (INum n0, INum n1) -> 57 | INum $ case op of 58 | Plus -> n0 + n1 59 | Mult -> n0 * n1 60 | Minus -> n0 - n1 61 | Div -> n0 `div` n1 62 | _ -> error "[Runtime error]: binary operation on non-numbers" 63 | eval' p ts (IBooleanOp op e0 e1) = 64 | case eval' p ts e0 of 65 | IBool b0 -> 66 | IBool $ case op of 67 | And -> b0 && unwrap (eval' p ts e1) 68 | Or -> b0 || unwrap (eval' p ts e1) 69 | _ -> error "[Runtime error]: boolean operation on non-booleans" 70 | where unwrap (IBool x) = x 71 | unwrap _ = error "[Runtime error]: boolean operation on non-booleans" 72 | eval' p ts (IUnaryOp op e) = 73 | case eval' p ts e of 74 | INum n -> 75 | INum $ case op of 76 | Positive -> n 77 | Negative -> -n 78 | Not -> error "[Runtime error]: unary 'not' on number" 79 | IBool b -> 80 | IBool $ case op of 81 | Positive -> error "[Runtime error]: unary '+' on boolean" 82 | Negative -> error "[Runtime error]: unary '-' on boolean" 83 | Not -> not b 84 | _ -> error "[Runtime error]: unary operation on non-number or non-boolean" 85 | -------------------------------------------------------------------------------- /test_script.py: -------------------------------------------------------------------------------- 1 | ############################################################################################################################## 2 | # # 3 | # Usage: python3 test_script.py # 4 | # Requirements: 1) Adjust path in "test_dir" to reflect the path of your test directory, relative to the script's directory. # 5 | # 2) Adjust path in "custom_exec_name" to reflect the path of your custom interpreter executable, relative to # 6 | # the directory where your tests exist. # 7 | # 3) [Optionally] Adjust the value of "max_timeout" to reflect the max time that the custom interpeter or ghc # 8 | # are allowed to run before being interrupted. # 9 | ############################################################################################################################## 10 | 11 | import glob 12 | import subprocess 13 | import time 14 | 15 | 16 | test_dir = './tests' 17 | custom_exec_name = './src/TestMain' 18 | 19 | max_timeout = 20 20 | 21 | OKGREEN = '\033[92m' 22 | FAIL = '\033[91m' 23 | ENDC = '\033[0m' 24 | 25 | 26 | def main(): 27 | failed_tests = [] 28 | n_failed_tests = 0 29 | 30 | start = time.time() 31 | 32 | print('> Begin testing ', end="", flush=True) 33 | for testfile in glob.glob(f'{test_dir}/*'): 34 | success = test_custom_vs_ghc(testfile) 35 | 36 | if not success: 37 | failed_tests.append(testfile) 38 | n_failed_tests += 1 39 | print(FAIL + "F" + ENDC, end="", flush=True) 40 | else: 41 | print(OKGREEN + "." + ENDC, end="", flush=True) 42 | 43 | end = time.time() 44 | 45 | print('\n> Finished testing...') 46 | print('> Number of failed tests:', n_failed_tests) 47 | 48 | if n_failed_tests: 49 | print('> Failed tests:') 50 | for test in failed_tests: 51 | print('> ', test) 52 | 53 | print('> Total elapsed time:', end - start) 54 | print('> Bye!') 55 | 56 | 57 | def check_with_custom(testfile): 58 | exec_name = custom_exec_name 59 | try: 60 | res = subprocess.check_output( 61 | f'{exec_name} < {testfile}; exit 0', 62 | stderr=subprocess.STDOUT, 63 | timeout=max_timeout, 64 | shell=True 65 | ) 66 | except: 67 | res = b'error' 68 | 69 | return res.decode().strip() 70 | 71 | 72 | def check_with_ghc(testfile): 73 | tmpname = testfile + '_tmp' 74 | rm_cmd = f'rm -f ./{tmpname} ./{tmpname}.hi ./{tmpname}.o ./{tmpname}.hs' 75 | 76 | try: 77 | res = subprocess.check_output( 78 | f'cp {testfile} {tmpname}.hs && printf "\n\nmain = print result\n\n" >> {tmpname}.hs \ 79 | && ghc {tmpname}.hs && ./{tmpname} && {rm_cmd}; exit 0', 80 | stderr=subprocess.STDOUT, 81 | timeout=max_timeout, 82 | shell=True 83 | ) 84 | except: 85 | subprocess.check_output(rm_cmd, shell=True) # Cleanup leftovers 86 | res = b'error' 87 | 88 | res = res.decode().strip() 89 | 90 | if 'error' in res.lower(): 91 | res = 'error' 92 | else: 93 | res = res.split('\n')[-1].strip() 94 | 95 | return res 96 | 97 | 98 | def test_custom_vs_ghc(testfile): 99 | ghc_res = check_with_ghc(testfile) 100 | cus_res = check_with_custom(testfile) 101 | 102 | if ghc_res == 'error' or cus_res == 'error': 103 | return False 104 | 105 | if '.' in ghc_res: 106 | ghc_res = ghc_res.split('.')[0] 107 | 108 | return ghc_res == cus_res 109 | 110 | 111 | if __name__ == '__main__': 112 | main() 113 | -------------------------------------------------------------------------------- /src/Transform.hs: -------------------------------------------------------------------------------- 1 | module Transform (transform) where 2 | 3 | import Types 4 | 5 | type MapParams = [(String, [String])] -- Maps "function name" to "parameter array" 6 | type MapIndex = [(String, Int)] -- Maps "function name" to "current CALL index to be used" 7 | 8 | type TransformationUtilities = ([IDefinition], [IDefinition], MapIndex, MapParams) 9 | 10 | transform :: FProgram -> IProgram 11 | transform fprog = iprog 12 | where 13 | util = add_actuals fprog ([], [], [], []) 14 | (iFunc, iAct, _, _) = convert_to_unary fprog util 15 | iAct' = find_and_reverse_actuals iAct 16 | iprog = iFunc ++ iAct' 17 | 18 | -- 1st pass 19 | 20 | -- Parse the FDefinitions and create empty IActuals for each unique parameter of the FProgram. 21 | -- Side effect: Create "mapIndex" and "mapParams" 22 | add_actuals :: FProgram -> TransformationUtilities -> TransformationUtilities 23 | add_actuals (_, []) util = util 24 | add_actuals (res, (fdef : fdefs)) (iFunc, iAct, mapIndex, mapParams) = 25 | add_actuals (res, fdefs) (iFunc, iAct', mapIndex', mapParams') 26 | where 27 | (fname, fparams, fexpr) = fdef 28 | iAct' = parse_def_for_actuals fparams iAct 29 | mapIndex' = ((fname, 0) : mapIndex) 30 | mapParams' = ((fname, fparams) : mapParams) 31 | 32 | -- Parse the "Parameter" field of an FDefinition and create empty IActuals for each param. 33 | parse_def_for_actuals :: [String] -> [IDefinition] -> [IDefinition] 34 | parse_def_for_actuals [] iAct = iAct 35 | parse_def_for_actuals (param : rest) iAct = ( (param, IActuals []) : iAct' ) 36 | where 37 | iAct' = parse_def_for_actuals rest iAct 38 | 39 | -- // 1st pass 40 | 41 | -- 2nd pass 42 | 43 | -- (wrapper) Combine "result" with the rest of "FDefinitions" and transform it to an IProgram 44 | convert_to_unary :: FProgram -> TransformationUtilities -> TransformationUtilities 45 | convert_to_unary (res, fdefs) util = 46 | convert_fdefs_to_unary totalFdefs util 47 | where 48 | totalFdefs = (("result", [], res) : fdefs) 49 | 50 | -- Convert FDefinitions to IDefinitions 51 | convert_fdefs_to_unary :: [FDefinition] -> TransformationUtilities -> TransformationUtilities 52 | convert_fdefs_to_unary [] util = util 53 | convert_fdefs_to_unary ((fname, _, fexpr) : rs) util = 54 | convert_fdefs_to_unary rs (iFunc', iAct', mapIndex', mapParams) 55 | where 56 | (iFunc, iAct, mapIndex, mapParams) = util 57 | (iExpr, (_, iAct', mapIndex', _)) = convert_fexpr_to_unary fexpr util 58 | iDef = (fname, iExpr) 59 | iFunc' = (iDef : iFunc) 60 | 61 | -- Convert FExpr to IExpr (updating the "actuals" lists if needed) 62 | convert_fexpr_to_unary :: FExpr -> TransformationUtilities -> (IExpr, TransformationUtilities) 63 | convert_fexpr_to_unary (FVar tkn) util = -- util = (iFunc, iAct, mapIndex, mapP) 64 | (IVar tkn, util) 65 | convert_fexpr_to_unary (FNum tkn) util = 66 | (INum tkn, util) 67 | convert_fexpr_to_unary (FBool tkn) util = 68 | (IBool tkn, util) 69 | convert_fexpr_to_unary (FBinaryOp op fexp1 fexp2) (iFunc, iAct, mapIndex, mapP) = 70 | (iexpFinal, (iFunc, iAct2, mapIndex2, mapP)) 71 | where 72 | (iexp1, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp1 (iFunc, iAct, mapIndex, mapP) 73 | (iexp2, (_, iAct2, mapIndex2, _)) = convert_fexpr_to_unary fexp2 (iFunc, iAct1, mapIndex1, mapP) 74 | iexpFinal = IBinaryOp op iexp1 iexp2 75 | convert_fexpr_to_unary (FBooleanOp op fexp1 fexp2) (iFunc, iAct, mapIndex, mapP) = 76 | (iexpFinal, (iFunc, iAct2, mapIndex2, mapP)) 77 | where 78 | (iexp1, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp1 (iFunc, iAct, mapIndex, mapP) 79 | (iexp2, (_, iAct2, mapIndex2, _)) = convert_fexpr_to_unary fexp2 (iFunc, iAct1, mapIndex1, mapP) 80 | iexpFinal = IBooleanOp op iexp1 iexp2 81 | convert_fexpr_to_unary (FCompOp op fexp1 fexp2) (iFunc, iAct, mapIndex, mapP) = 82 | (iexpFinal, (iFunc, iAct2, mapIndex2, mapP)) 83 | where 84 | (iexp1, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp1 (iFunc, iAct, mapIndex, mapP) 85 | (iexp2, (_, iAct2, mapIndex2, _)) = convert_fexpr_to_unary fexp2 (iFunc, iAct1, mapIndex1, mapP) 86 | iexpFinal = ICompOp op iexp1 iexp2 87 | convert_fexpr_to_unary (FIfThenElse fexp1 fexp2 fexp3) (iFunc, iAct, mapIndex, mapP) = 88 | (iexpFinal, (iFunc, iAct3, mapIndex3, mapP)) 89 | where 90 | (iexp1, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp1 (iFunc, iAct, mapIndex, mapP) 91 | (iexp2, (_, iAct2, mapIndex2, _)) = convert_fexpr_to_unary fexp2 (iFunc, iAct1, mapIndex1, mapP) 92 | (iexp3, (_, iAct3, mapIndex3, _)) = convert_fexpr_to_unary fexp3 (iFunc, iAct2, mapIndex2, mapP) 93 | iexpFinal = IIfThenElse iexp1 iexp2 iexp3 94 | convert_fexpr_to_unary (FUnaryOp op fexp) (iFunc, iAct, mapIndex, mapP) = 95 | (iexpFinal, (iFunc, iAct1, mapIndex1, mapP)) 96 | where 97 | (iexp, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp (iFunc, iAct, mapIndex, mapP) 98 | iexpFinal = IUnaryOp op iexp 99 | convert_fexpr_to_unary (FParens fexp) (iFunc, iAct, mapIndex, mapP) = 100 | (iexpFinal, (iFunc, iAct1, mapIndex1, mapP)) 101 | where 102 | (iexp, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexp (iFunc, iAct, mapIndex, mapP) 103 | iexpFinal = IParens iexp 104 | convert_fexpr_to_unary (FCall str fpar) (iFunc, iAct, mapIndex, mapP) = 105 | (iexpFinal, (iFunc, iAct1, mapIndex2, mapP)) 106 | where 107 | (findex, mapIndex1) = find_and_update_index str mapIndex 108 | iexpFinal = ICall findex str 109 | params = find_params str mapP 110 | (_, iAct1, mapIndex2, _) = update_actuals fpar params (iFunc, iAct, mapIndex1, mapP) 111 | 112 | update_actuals :: [FExpr] -> [String] -> TransformationUtilities -> TransformationUtilities 113 | update_actuals [] [] util = util 114 | update_actuals (fexpr : fs) (param : ps) (iFunc, iAct, mapIndex, mapP) = 115 | update_actuals fs ps (iFunc, iAct2, mapIndex1, mapP) 116 | where 117 | previous_actuals_len = length (find_actuals param iAct) 118 | (iexpr, (_, iAct1, mapIndex1, _)) = convert_fexpr_to_unary fexpr (iFunc, iAct, mapIndex, mapP) 119 | new_actuals_len = length (find_actuals param iAct1) 120 | index_to_insert_iexpr = new_actuals_len - previous_actuals_len 121 | iAct2 = find_and_update_actuals param index_to_insert_iexpr iexpr iAct1 122 | 123 | find_and_update_index :: String -> MapIndex -> (Int, MapIndex) 124 | find_and_update_index fn1 ((fn2, fi) : rs) = 125 | if fn1 == fn2 then (fi, ((fn2, fi+1) : rs)) else (findex, ((fn2, fi) : res)) 126 | where 127 | (findex, res) = find_and_update_index fn1 rs 128 | 129 | find_and_update_actuals :: String -> Int -> IExpr -> [IDefinition] -> [IDefinition] 130 | find_and_update_actuals n1 index iexpr ((n2, act) : rs) = 131 | if n1 == n2 then case act of 132 | IActuals ls -> ((n1, IActuals (insert_expr_in_actuals iexpr ls index)) : rs) 133 | else 134 | ((n2, act) : res) 135 | where 136 | res = find_and_update_actuals n1 index iexpr rs 137 | 138 | find_actuals :: String -> [IDefinition] -> [IExpr] 139 | find_actuals n1 ((n2, act) : rs) = 140 | if n1 == n2 then case act of IActuals ls -> ls 141 | else find_actuals n1 rs 142 | 143 | find_params :: String -> [(String, [String])] -> [String] 144 | find_params p1 ((p2, x) : ps) = if p1 == p2 then x else find_params p1 ps 145 | 146 | insert_expr_in_actuals :: IExpr -> [IExpr] -> Int -> [IExpr] 147 | insert_expr_in_actuals iexpr actuals 0 = (iexpr : actuals) 148 | insert_expr_in_actuals iexpr (actual : rs) index = 149 | actual : (insert_expr_in_actuals iexpr rs (index - 1)) 150 | 151 | -- // 2nd pass 152 | 153 | -- 3rd pass 154 | find_and_reverse_actuals :: [IDefinition] -> [IDefinition] 155 | find_and_reverse_actuals [] = [] 156 | find_and_reverse_actuals ((n, act) : rs) = 157 | case act of IActuals ls -> ((n, IActuals (reverse ls)) : res) 158 | where 159 | res = find_and_reverse_actuals rs 160 | -- // 3rd pass 161 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------------------------------------------------ 2 | --- This module implements a parser for a subset of the haskell language represented by the FProgram type (Types.hs) --- 3 | ------------------------------------------------------------------------------------------------------------------------ 4 | 5 | module Parser ( 6 | parseExpression, 7 | parseProgram, 8 | programParser, 9 | parseFile, 10 | parsePrettyFile, 11 | programPrettyParser 12 | ) where 13 | 14 | import Types 15 | import Control.Monad ( guard, void ) 16 | import Text.Parsec 17 | import qualified Text.Parsec.Expr as E 18 | import Text.Parsec.String (Parser) 19 | import Control.Monad.Identity (Identity ) 20 | import Text.Pretty.Simple (pPrint) 21 | 22 | 23 | ----------------------------------------------------------------------------------------- 24 | --------------------- Assisting functions used for tokens and terms --------------------- 25 | ----------------------------------------------------------------------------------------- 26 | 27 | -- Consumes all whitespace characters in the input stream. 28 | whitespace :: Parser () 29 | whitespace = void $ many $ oneOf " \t\r\n" 30 | 31 | -- Invokes a given Parser and then consumes any following whitespace. 32 | -- The returned value is whatever the parser returns. 33 | lexeme :: Parser a -> Parser a 34 | lexeme p = p <* whitespace 35 | 36 | -- Consumes a single symbol lexeme. 37 | symbol :: Char -> Parser () 38 | symbol ch = void $ lexeme $ char ch 39 | 40 | -- Consumes a given keyword k if matched, or fails without consuming any input. 41 | keyword :: String -> Parser String 42 | keyword k = try $ k <$ do { string k ; notFollowedBy $ digit <|> letter <|> char '_'} 43 | 44 | -- Similar to keyword, but instead only parses operator characters instead of an identifier. 45 | operator :: String -> Parser String 46 | operator s = try $ lexeme $ s <$ do {string s ; notFollowedBy (oneOf "+-*^/<>=|&")} 47 | 48 | -- Parses an identifier: [a-zA-Z_][a-zA-Z0-9_] 49 | identifier :: Parser String 50 | identifier = lexeme $ (:) <$> firstLetter <*> many restLetters 51 | where firstLetter = letter <|> char '_' 52 | restLetters = digit <|> firstLetter 53 | 54 | -- Creates an identifier parser that consumes its input only if it doesn't correspond to a keyword. 55 | blackListIdentifier :: [String] -> Parser String 56 | blackListIdentifier blackList = try $ do {s <- identifier ; guard (s `notElem` blackList) ; return s} 57 | 58 | 59 | ------------------------------------------------------------------------------------------ 60 | ----------------------- Construct the term parser of an expression ----------------------- 61 | ------------------------------------------------------------------------------------------ 62 | 63 | -- A list of keywords which will not be considered as identifiers 64 | keywords :: [String] 65 | keywords = ["False", "True", "else", "if", "not", "result", "then"] 66 | 67 | -- Parses identifiers, but not keywords. 68 | identifierToken :: Parser String 69 | identifierToken = blackListIdentifier keywords 70 | 71 | -- Parses number literals. 72 | numberToken :: Parser FExpr 73 | numberToken = lexeme $ FNum . read <$> many1 digit 74 | 75 | -- Parses the keywords "True" and "False". 76 | boolToken :: Parser FExpr 77 | boolToken = lexeme $ FBool . read <$> (keyword "True" <|> keyword "False") 78 | 79 | -- Parses an expression wrapped in parentheses recursively. 80 | parens :: Parser FExpr 81 | parens = try $ FParens <$> (symbol '(' *> parseExpression <* symbol ')') 82 | 83 | -- Parses an if-then-else expression. 84 | ifThenElse :: Parser FExpr 85 | ifThenElse = do void $ lexeme $ keyword "if" 86 | expr1 <- parseExpression 87 | void $ lexeme $ keyword "then" 88 | expr2 <- parseExpression 89 | void $ lexeme $ keyword "else" 90 | FIfThenElse expr1 expr2 <$> parseExpression 91 | 92 | -- Parses a call expression given the function's identifier. 93 | callExpr :: String -> Parser FExpr 94 | callExpr s = do symbol '(' 95 | xs <- parseExpression `sepBy` symbol ',' 96 | FCall s xs <$ symbol ')' 97 | 98 | -- This parser invokes the call parser and if it fails, then it invokes the identifierToken parser. 99 | -- However, both of these parsers work by first invoking the identifierToken parser. Thus, to avoid 100 | -- unnecessary backtracking, term0 factors the identifierToken parser invocation (left-factoring). 101 | term0 :: Parser FExpr 102 | term0 = do s <- identifierToken 103 | callExpr s <|> return (FVar s) 104 | 105 | -- Parses an expression term. 106 | term :: Parser FExpr 107 | term = choice [ifThenElse, numberToken, boolToken, parens, term0] 108 | 109 | 110 | ------------------------------------------------------------------------------------ 111 | ------------------ Adding the operators to the expression parser ------------------ 112 | ------------------------------------------------------------------------------------ 113 | 114 | -- The following implements a table-driven parsing for operators. 115 | operatorTable :: E.OperatorTable String () Identity FExpr 116 | operatorTable = 117 | [ 118 | [ 119 | prefix "+" $ FUnaryOp Positive, 120 | prefix "-" $ FUnaryOp Negative 121 | ], 122 | [ 123 | binary "*" (FBinaryOp Mult) E.AssocLeft, 124 | binary "/" (FBinaryOp Div) E.AssocLeft 125 | ], 126 | [ 127 | binary "+" (FBinaryOp Plus) E.AssocLeft, 128 | binary "-" (FBinaryOp Minus) E.AssocLeft 129 | ], 130 | [ 131 | binary "<=" (FCompOp LtEq) E.AssocNone, 132 | binary ">=" (FCompOp GtEq) E.AssocNone, 133 | binary "<" (FCompOp Lt) E.AssocNone, 134 | binary ">" (FCompOp Gt) E.AssocNone, 135 | binary "==" (FCompOp Eq) E.AssocNone, 136 | binary "/=" (FCompOp Neq) E.AssocNone 137 | ], 138 | [ 139 | prefixK "not" $ FUnaryOp Not 140 | ], 141 | [ 142 | binary "||" (FBooleanOp Or ) E.AssocLeft, 143 | binary "&&" (FBooleanOp And) E.AssocLeft 144 | ] 145 | ] 146 | where 147 | prefix s f = E.Prefix (f <$ operator s) 148 | prefixK k f = E.Prefix (f <$ lexeme (keyword k)) 149 | binary s f = E.Infix (f <$ operator s) 150 | --binaryK k f = E.Infix (f <$ keyword k) 151 | 152 | -- Builds an expression parser given the operator precedence table and the term parser. 153 | parseExpression :: Parser FExpr 154 | parseExpression = E.buildExpressionParser operatorTable term 155 | 156 | 157 | ----------------------------------------------------------------------------------------- 158 | ------------------------- The construction of the programParser ------------------------- 159 | ----------------------------------------------------------------------------------------- 160 | 161 | defParser :: Parser FDefinition 162 | defParser = lexeme $ do s <- identifierToken <* symbol '(' 163 | xs <- identifierToken `sepBy` symbol ',' 164 | void $ symbol ')' <* symbol '=' 165 | expr <- parseExpression 166 | (s, xs, expr) <$ (eof <|> symbol ';') 167 | 168 | defResultParser :: Parser FExpr 169 | defResultParser = lexeme $ do void $ whitespace *> lexeme (keyword "result") <* symbol '=' 170 | parseExpression <* (eof <|> symbol ';') 171 | 172 | parseProgram :: Parser FProgram 173 | parseProgram = (,) <$> defResultParser <*> many defParser 174 | 175 | 176 | -------------------------------------------------------------------------------------------- 177 | ------------------------------ Functions that run the parsers ------------------------------ 178 | -------------------------------------------------------------------------------------------- 179 | 180 | -- Given a Parser p, modify it so that before using p all whitespace is consumed. After the parsing 181 | -- finishes, check if the input has been completely consumed; if not, the parser will fail. 182 | mkParser :: Parser a -> String -> Either ParseError a 183 | mkParser p = parse (whitespace *> p <* eof) "" 184 | 185 | -- Given a string, run the program parser. 186 | programParser :: String -> Either ParseError FProgram 187 | programParser = mkParser parseProgram 188 | 189 | -- Given a file path, run the program parser on that file. 190 | parseFile :: FilePath -> IO (Either ParseError FProgram) 191 | parseFile = fmap programParser . readFile 192 | 193 | 194 | -------------------------------------------------------------------------------------------------- 195 | -- A variety of the 3 parsers using the pPrint for a more readable representation of the output -- 196 | -------------------------------------------------------------------------------------------------- 197 | 198 | mkPrettyParser :: (Show a) => Parser a -> String -> IO () 199 | mkPrettyParser p = pPrint . mkParser p 200 | 201 | programPrettyParser :: String -> IO () 202 | programPrettyParser = mkPrettyParser parseProgram 203 | 204 | parsePrettyFile :: FilePath -> IO () 205 | parsePrettyFile path = readFile path >>= programPrettyParser 206 | --------------------------------------------------------------------------------