/exercise1/exercise1.lhs
Haskell | 1133 lines | 786 code | 90 blank | 257 comment | 63 complexity | e9c759ede1181a1f5fcc222e4334c667 MD5 | raw file
1\documentclass[11pt]{article} 2%% Literate Haskell script intended for lhs2TeX. 3 4%include polycode.fmt 5%format `union` = "\cup" 6%format alpha = "\alpha" 7%format gamma "\gamma" 8%format capGamma = "\Gamma" 9%format tau = "\tau" 10%format tau1 = "\tau_{1}" 11%format tau2 = "\tau_{2}" 12%format t1 = "t_{1}" 13%format t2 = "t_{2}" 14%format t3 = "t_{3}" 15 16\usepackage{fullpage} 17\usepackage{verbatim} 18\usepackage{mathpazo} 19\usepackage{graphicx} 20\usepackage{color} 21\usepackage[centertags]{amsmath} 22\usepackage{amsfonts} 23\usepackage{amsthm} 24\usepackage{soul} 25\usepackage{listings} 26\usepackage{stmaryrd} 27 28\title{Exercise 1, CS 555} 29\author{\textbf{By:} Sauce Code Team (Dandan Mo, Qi Lu, Yiming Yang)} 30\date{\textbf{Due:} February 27th, 2012} 31\begin{document} 32 \maketitle 33 \thispagestyle{empty} 34 \newpage 35 36\section{Concrete Lambda Language} 37 38We start the project with a small core lambda language, consisting of the lambda calculus with booleans 39and integers. 40Here is the concrete syntax in BNF: 41 42\begin{verbatim} 43Type --> arr lpar Type comma Type rpar 44 | Bool_keyword 45 | Int_keyword 46 47Term --> identifier 48 | abs_keyword lpar identifier colon Type fullstop Term rpar 49 | app_keyword lpar Term comma Term rpar 50 | true_keyword 51 | false_keyword 52 | if_keyword Term then_keyword Term else_keyword Term fi_keyword 53 | inliteral 54 | plus lpar Term comma Term rpar 55 | minus lpar Term comma Term rpar 56 | div lpar Term comma Term rpar 57 | nand lpar Term comma Term rpar 58 | equal lpar Term comma Term rpar 59 | lt lpar Term comma Term rpar 60 | lpar Term rpar 61\end{verbatim} 62 63Here are the terminal symbols used in the grammar above: 64\newpage 65 66\begin{verbatim} 67arrow -> 68lpar ( 69comma , 70rpar ) 71Bool_keyword Bool 72Int_keyword Int 73identifier an identifier, as in Haskell 74abs_keyword abs 75colon : 76fullstop . 77app_keyword app 78true_keyword true 79false_keyword false 80if_keyword if 81then_keyword then 82else_keyword else 83fi_keyword fi 84inliteral a non-negative decimal numeral 85plus + 86minus - 87mul * 88div / 89nand ^ 90equal = 91lt < 92\end{verbatim} 93 94White space, such as space, tab, and newline characters, is permitted between tokens. White space is 95required between adjacent keyword tokens. 96 97Here are some example programs: 98\\ \\ 99 100 app (abs (x: Int . 1234), 10) 101 102-------------------------------------------------------------------------\\ 103 104 if true then true else false fi 105 106-------------------------------------------------------------------------\\ 107 108 if =(0,0) then 8 else 9 fi 109 110-------------------------------------------------------------------------\\ 111 112 /(4294967295,76) 113 114-------------------------------------------------------------------------\\ 115 116\section{Lexer and Parser} 117 1181):Lexer takes input string, returns a list of tokens. We define a data structure called Token as the followings,together with the show functions:\\ 119\begin{code} 120data Token = ARROW 121 | LPAR 122 | COMMA 123 | RPAR 124 | BOOL 125 | INT 126 | ABS 127 | COLON 128 | FULLSTOP 129 | APP 130 | TRUE 131 | FALSE 132 | IF 133 | THEN 134 | ELSE 135 | FI 136 | PLUS 137 | SUB 138 | MUL 139 | DIV 140 | NAND 141 | EQUAL 142 | LT_keyword 143 | ID String 144 | NUM String 145 deriving Eq 146 147instance Show Token where 148 show ARROW = "->" 149 show LPAR = "(" 150 show COMMA = "," 151 show RPAR = ")" 152 show BOOL = "Bool" 153 show INT = "Int" 154 show ABS = "abs" 155 show COLON = ":" 156 show FULLSTOP = "." 157 show APP = "app" 158 show TRUE = "true" 159 show FALSE = "false" 160 show IF = "if" 161 show THEN = "then" 162 show ELSE = "else" 163 show FI = "fi" 164 show PLUS = "+" 165 show SUB = "-" 166 show MUL = "*" 167 show DIV = "/" 168 show NAND = "^" 169 show EQUAL = "=" 170 show LT_keyword = "<" 171 show (ID id) = id 172 show (NUM num) = num 173\end{code} 174 175For the Token identifier and decimal number, we use regular expression to recognize them, so we have two corresponding subscan function to deal with them.\\ 176 177\begin{code} 178--reguar expresiion 179ex_num = mkRegex "(0|[1-9][0-9]*)" 180ex_id = mkRegex "([a-zA-Z][a-zA-Z0-9_]*)" 181 182--subscan for id 183subscan1 :: String -> Maybe ([Token],String) 184subscan1 str = case (matchRegexAll ex_id str) of 185 Just (a1,a2,a3,a4) -> case a1 of 186 "" -> Just ([ID a2],a3) 187 _ -> Nothing 188 Nothing -> Nothing 189 190--subscan for num 191subscan2 :: String -> Maybe ([Token],String) 192subscan2 str = case (matchRegexAll ex_num str) of 193 Just (a1,a2,a3,a4) -> case a1 of 194 "" -> Just ([NUM a2],a3) 195 _ -> Nothing 196 Nothing -> Nothing 197\end{code} 198 199Function scan takes an input string and returns a list tokens. If unexpected symbols exists,or the input string cannot mactch any defined token, the function reports errors and the program stops at the lexer level.\\ 200 201\begin{code} 202--lexer 203scan :: String -> [Token] 204scan "" = [] 205----white spase 206scan (' ':xs) = scan xs 207scan ('\t':xs) = scan xs 208scan ('\n':xs) = scan xs 209----keyword 210scan (':':xs) = [COLON] ++ scan xs 211scan ('-':'>':xs) = [ARROW] ++ scan xs 212scan ('(':xs) = [LPAR] ++ scan xs 213scan (',':xs) = [COMMA] ++ scan xs 214scan (')':xs) = [RPAR] ++ scan xs 215scan ('B':'o':'o':'l':xs) = [BOOL] ++ scan xs 216scan ('I':'n':'t':xs) = [INT] ++ scan xs 217scan ('a':'b':'s':xs) = [ABS] ++ scan xs 218scan ('a':'p':'p':xs) = [APP] ++ scan xs 219scan ('.':xs) = [FULLSTOP] ++ scan xs 220scan ('t':'r':'u':'e':xs) = [TRUE] ++ scan xs 221scan ('f':'a':'l':'s':'e':xs) = [FALSE] ++ scan xs 222scan ('i':'f':xs) = [IF] ++ scan xs 223scan ('t':'h':'e':'n':xs) = [THEN] ++ scan xs 224scan ('e':'l':'s':'e':xs) = [ELSE] ++ scan xs 225scan ('f':'i':xs) = [FI] ++ scan xs 226scan ('+':xs) = [PLUS] ++ scan xs 227scan ('-':xs) = [SUB] ++ scan xs 228scan ('*':xs) = [MUL] ++ scan xs 229scan ('/':xs) = [DIV] ++ scan xs 230scan ('^':xs) = [NAND] ++ scan xs 231scan ('=':xs) = [EQUAL] ++ scan xs 232scan ('<':xs) = [LT_keyword] ++ scan xs 233----id and num 234scan str = case subscan1 str of 235 Nothing -> case subscan2 str of 236 Nothing -> error "[Scan]err: unexpected symbols!" 237 Just (tok,xs) -> tok ++ scan xs 238 Just (tok,xs) -> tok ++ scan xs 239str str = error "[Scan]err: unexpected symbols!" 240\end{code} 241 2422):Parser takes a list of tokens, returns a term. We define the two data structures Type and Term, and two functions parseType and parseTerm to deal with them.\\ 243parseType function returns a matched Type and the remaining tokens, parseTerm function returns a matched Term and the remaining tokens.\\ 244 245Data structure:\\ 246\begin{code} 247data Type = TypeArrow Type Type 248 | TypeBool 249 | TypeInt 250 deriving Eq 251 252instance Show Type where 253 show (TypeArrow tau1 tau2) = "->(" ++ show tau1 ++ "," ++ show tau2 ++ ")" 254 show TypeBool = "Bool" 255 show TypeInt = "Int" 256 257type Var = String 258data Term = Var Var 259 | Abs Var Type Term 260 | App Term Term 261 | Tru 262 | Fls 263 | If Term Term Term 264 | IntConst Integer 265 | IntAdd Term Term 266 | IntSub Term Term 267 | IntMul Term Term 268 | IntDiv Term Term 269 | IntNand Term Term 270 | IntEq Term Term 271 | IntLt Term Term 272 deriving Eq 273 274instance Show Term where 275 show (Var x) = x 276 show (Abs x tau t) = "abs(" ++ x ++ ":" ++ show tau ++ "." ++ show t ++ ")" 277 show (App t1 t2) = "app(" ++ show t1 ++ "," ++ show t2 ++ ")" 278 show Tru = "true" 279 show Fls = "false" 280 show (If t1 t2 t3) = "if " ++ show t1 ++ " then " ++ show t2 ++ " else " ++ show t3 ++ " fi" 281 show (IntConst n) = show n 282 show (IntAdd t1 t2) = "+(" ++ show t1 ++ "," ++ show t2 ++ ")" 283 show (IntSub t1 t2) = "-(" ++ show t1 ++ "," ++ show t2 ++ ")" 284 show (IntMul t1 t2) = "*(" ++ show t1 ++ "," ++ show t2 ++ ")" 285 show (IntDiv t1 t2) = "/(" ++ show t1 ++ "," ++ show t2 ++ ")" 286 show (IntNand t1 t2) = "^(" ++ show t1 ++ "," ++ show t2 ++ ")" 287 show (IntEq t1 t2) = "=(" ++ show t1 ++ "," ++ show t2 ++ ")" 288 show (IntLt t1 t2) = "<(" ++ show t1 ++ "," ++ show t2 ++ ")" 289 290\end{code} 291 292Function parseType, parseTerm and parse:\\ 293\begin{code} 294--parser 295 296--type parser 297parseType :: [Token] -> Maybe (Type,[Token]) 298parseType (BOOL:ty) = Just (TypeBool,ty) 299parseType (INT:ty) = Just (TypeInt,ty) 300parseType (RPAR:ty) = parseType ty 301parseType (COMMA:ty) = parseType ty 302parseType (ARROW:LPAR:ty) = 303 case parseType ty of 304 Just (t1,(COMMA:tl)) -> case parseType tl of 305 Just (t2,(RPAR:tll)) -> Just ((TypeArrow t1 t2),tll) 306 Nothing -> Nothing 307 Nothing -> Nothing 308parseType tok = error "[P]err: type parsing error!" 309 310--term parser 311parseTerm :: [Token] -> Maybe (Term,[Token]) 312----id 313parseTerm ((ID id):ts) = Just ((Var id),ts) 314----num 315parseTerm ((NUM num):ts) = Just ((IntConst (read num::Integer)),ts) 316----symbol 317--parseTerm (COMMA:ts) = parseTerm ts 318--parseTerm (COLON:ts) = parseTerm ts 319--parseTerm (RPAR:ts) = parseTerm ts 320--parseTerm (FULLSTOP:ts) = parseTerm ts 321----keyword 322parseTerm (THEN:ts) = parseTerm ts 323parseTerm (ELSE:ts) = parseTerm ts 324parseTerm (FI:ts) = parseTerm ts 325parseTerm (TRUE:ts) = Just (Tru,ts) 326parseTerm (FALSE:ts) = Just (Fls,ts) 327----(term) 328parseTerm (LPAR:ts) = case parseTerm ts of 329 Just (t,(RPAR:tl)) -> Just (t,tl) 330 Nothing -> Nothing 331 _ -> error "[P]err: t is not a term in the (t)" 332----op 333parseTerm (PLUS:LPAR:ts) = 334 case parseTerm ts of 335 Just (t1,(COMMA:tl)) -> case parseTerm tl of 336 Just (t2,(RPAR:tll)) -> Just ((IntAdd t1 t2),tll) 337 Nothing -> Nothing 338 _ -> error "[P]err: plus term" 339 Nothing -> Nothing 340 _ -> error "[P]err: plus term" 341parseTerm (SUB:LPAR:ts) = 342 case parseTerm ts of 343 Just (t1,(COMMA:tl)) -> case parseTerm tl of 344 Just (t2,(RPAR:tll)) -> Just ((IntSub t1 t2),tll) 345 Nothing -> Nothing 346 _ -> error "[P]err: sub term" 347 Nothing -> Nothing 348 _ -> error "[P]err: sub term" 349parseTerm (MUL:LPAR:ts) = 350 case parseTerm ts of 351 Just (t1,(COMMA:tl)) -> case parseTerm tl of 352 Just (t2,(RPAR:tll)) -> Just ((IntMul t1 t2),tll) 353 Nothing -> Nothing 354 _ -> error "[P]err: mul term" 355 Nothing -> Nothing 356 _ -> error "[P]err: mul term" 357parseTerm (DIV:LPAR:ts) = 358 case parseTerm ts of 359 Just (t1,(COMMA:tl)) -> case parseTerm tl of 360 Just (t2,(RPAR:tll)) -> Just ((IntDiv t1 t2),tll) 361 Nothing -> Nothing 362 _ -> error "[P]err: div term" 363 Nothing -> Nothing 364 _ -> error "[P]err: div term" 365parseTerm (NAND:LPAR:ts) = 366 case parseTerm ts of 367 Just (t1,(COMMA:tl)) -> case parseTerm tl of 368 Just (t2,(RPAR:tll)) -> Just ((IntNand t1 t2),tll) 369 Nothing -> Nothing 370 _ -> error "[P]err: nand term" 371 Nothing -> Nothing 372 _ -> error "[P]err: nand term" 373parseTerm (EQUAL:LPAR:ts) = 374 case parseTerm ts of 375 Just (t1,(COMMA:tl)) -> case parseTerm tl of 376 Just (t2,(RPAR:tll)) -> Just ((IntEq t1 t2),tll) 377 Nothing -> Nothing 378 _ -> error "[P]err: eq term" 379 Nothing -> Nothing 380 _ -> error "[P]err: eq term" 381parseTerm (LT_keyword:LPAR:ts) = 382 case parseTerm ts of 383 Just (t1,(COMMA:tl)) -> case parseTerm tl of 384 Just (t2,(RPAR:tll)) -> Just ((IntLt t1 t2),tll) 385 Nothing -> Nothing 386 _ -> error "[P]err: lt term" 387 Nothing -> Nothing 388 _ -> error "[P]err: lt term" 389----if-then-else 390parseTerm (IF:ts) = 391 case parseTerm ts of 392 Just (t1,(THEN:tl)) -> case parseTerm tl of 393 Just (t2,(ELSE:tll)) -> case parseTerm tll of 394 Just (t3,(FI:tn)) -> Just((If t1 t2 t3),tn) 395 Nothing -> Nothing 396 _ -> error "[P]err: if term" 397 Nothing -> Nothing 398 _ -> error "[P]err: if term" 399 Nothing -> Nothing 400 _ -> error "[P]err: if term" 401 402----abs 403parseTerm (ABS:LPAR:(ID id):COLON:ts) = 404 case parseType ts of 405 Just (ty,(FULLSTOP:tl)) -> case parseTerm tl of 406 Just (t,(RPAR:tll)) -> Just ((Abs id ty t),tll) 407 Nothing -> Nothing 408 _ -> error "[P]err: abs term" 409 Nothing -> Nothing 410 _ -> error "[P]err: abs term" 411----app 412parseTerm (APP:LPAR:ts) = case parseTerm ts of 413 Just (t1,(COMMA:tl)) -> case parseTerm tl of 414 Just (t2,(RPAR:tll)) -> Just ((App t1 t2),tll) 415 Nothing -> Nothing 416 _ -> error "[P]err: app term" 417 Nothing -> Nothing 418 _ -> error "[P]err: app term" 419----otherwise 420parseTerm tok = Nothing 421 422--parser 423parse :: [Token] -> Term 424parse t = 425 case parseTerm t of 426 Just (x,t) -> case t of 427 [] -> x 428 _ -> error "parsing error!" 429 Nothing -> error "parsing error!" 430 431 432\end{code} 433 434If the input string can't match any defined Term, function parser reports an error and the program stops at the parser level.\\ 435 436\section{Binding and Free Variables} 437Define functions to manipulate the abstract syntax. Place them together with the above type definitions 438in a module \textit{AbstractSyntax}. 439 440Enumerate the free variables of a term: 441\begin{code} 442fv :: Term -> [Var] 443fv (Var x) = [x] 444fv (Abs x _ t) = filter (/=x) (fv t) 445fv (App t1 t2) = (fv t1) ++ (fv t2) 446fv (If t1 t2 t3) = (fv t1) ++ (fv t2) ++ (fv t3) 447fv (IntAdd t1 t2) = (fv t1) ++ (fv t2) 448fv (IntSub t1 t2) = (fv t1) ++ (fv t2) 449fv (IntMul t1 t2) = (fv t1) ++ (fv t2) 450fv (IntDiv t1 t2) = (fv t1) ++ (fv t2) 451fv (IntNand t1 t2) = (fv t1) ++ (fv t2) 452fv (IntEq t1 t2) = (fv t1) ++ (fv t2) 453fv (IntLt t1 t2) = (fv t1) ++ (fv t2) 454fv _ = [] 455\end{code} 456 457Substitution: subst $x$ $s$ $t$, or in writing $[x 7 \rightarrow s]t$, is the result of substituting $s$ for $x$ in $t$. 458\begin{code} 459subst :: Var -> Term -> Term -> Term 460subst x s (Var v) = if x == v then s else (Var v) 461subst x s (Abs y tau t1) = 462 if x == y then 463 Abs y tau t1 464 else 465 Abs y tau (subst x s t1) 466subst x s (App t1 t2) = App (subst x s t1) (subst x s t2) 467subst x s (If t1 t2 t3) = If (subst x s t1) (subst x s t2) (subst x s t3) 468subst x s (IntAdd t1 t2) = IntAdd (subst x s t1) (subst x s t2) 469subst x s (IntSub t1 t2) = IntSub (subst x s t1) (subst x s t2) 470subst x s (IntMul t1 t2) = IntMul (subst x s t1) (subst x s t2) 471subst x s (IntDiv t1 t2) = IntDiv (subst x s t1) (subst x s t2) 472subst x s (IntNand t1 t2) = IntNand (subst x s t1) (subst x s t2) 473subst x s (IntEq t1 t2) = IntEq (subst x s t1) (subst x s t2) 474subst x s (IntLt t1 t2) = IntLt (subst x s t1) (subst x s t2) 475subst x s t = t 476\end{code} 477 478Syntactic values: primitive constants and abstractions are values. 479\begin{code} 480isValue :: Term -> Bool 481isValue (Abs _ _ _) = True 482isValue Tru = True 483isValue Fls = True 484isValue (IntConst _) = True 485isValue _ = False 486\end{code} 487\section{Structural Operational Semantics} 488 489\paragraph{} 490Express the small-step semantics, as defined in class, in Haskell code. The completed source code is as follows: 491 492\begin{code} 493 494module StructuralOperationalSemantics where 495import List 496import qualified AbstractSyntax as S 497import qualified IntegerArithmetic as I 498 499eval1 :: S.Term -> Maybe S.Term 500-- E-IFTRUE 501eval1 (S.If S.Tru t2 t3) = Just t2 502 503-- E-IFFALSE 504eval1 (S.If S.Fls t2 t3) = Just t3 505 506-- E-IF 507eval1 (S.If t1 t2 t3) = 508 case eval1 t1 of 509 Just t1' -> Just (S.If t1' t2 t3) 510 Nothing -> Nothing 511 512-- E-APPABS, E-APP1 and E-APP2 513eval1 (S.App t1 t2) = 514 if S.isValue t1 515 then if S.isValue t2 516 then case t1 of 517 S.Abs x tau11 t12 -> Just (S.subst x t2 t12) -- E-APPABS 518 _ -> Nothing 519 else case eval1 t2 of 520 Just t2' -> Just (S.App t1 t2') -- E-APP2 521 Nothing -> Nothing 522 else case eval1 t1 of 523 Just t1' -> Just (S.App t1' t2) -- E-APP1 524 Nothing -> Nothing 525 526eval1 (S.IntAdd t1 t2) = 527 if S.isValue t1 528 then case t1 of 529 S.IntConst n1 -> if S.isValue t2 530 then case t2 of 531 S.IntConst n2 -> Just (S.IntConst (I.intAdd n1 n2)) 532 _ -> Nothing 533 else case eval1 t2 of 534 Just t2' -> Just (S.IntAdd t1 t2') 535 Nothing -> Nothing 536 _ -> Nothing 537 else case eval1 t1 of 538 Just t1' -> Just (S.IntAdd t1' t2) 539 Nothing -> Nothing 540 541eval1 (S.IntSub t1 t2) = 542 if S.isValue t1 543 then case t1 of 544 S.IntConst n1 -> if S.isValue t2 545 then case t2 of 546 S.IntConst n2 -> Just (S.IntConst (I.intSub n1 n2)) 547 _ -> Nothing 548 else case eval1 t2 of 549 Just t2' -> Just (S.IntSub t1 t2') 550 Nothing -> Nothing 551 _ -> Nothing 552 else case eval1 t1 of 553 Just t1' -> Just (S.IntSub t1' t2) 554 Nothing -> Nothing 555 556eval1 (S.IntMul t1 t2) = 557 if S.isValue t1 558 then case t1 of 559 S.IntConst n1 -> if S.isValue t2 560 then case t2 of 561 S.IntConst n2 -> Just (S.IntConst (I.intMul n1 n2)) 562 _ -> Nothing 563 else case eval1 t2 of 564 Just t2' -> Just (S.IntMul t1 t2') 565 Nothing -> Nothing 566 _ -> Nothing 567 else case eval1 t1 of 568 Just t1' -> Just (S.IntMul t1' t2) 569 Nothing -> Nothing 570 571eval1 (S.IntDiv t1 t2) = 572 if S.isValue t1 573 then case t1 of 574 S.IntConst n1 -> if S.isValue t2 575 then case t2 of 576 S.IntConst n2 -> Just (S.IntConst (I.intDiv n1 n2)) 577 _ -> Nothing 578 else case eval1 t2 of 579 Just t2' -> Just (S.IntDiv t1 t2') 580 Nothing -> Nothing 581 _ -> Nothing 582 else case eval1 t1 of 583 Just t1' -> Just (S.IntDiv t1' t2) 584 Nothing -> Nothing 585 586eval1 (S.IntNand t1 t2) = 587 if S.isValue t1 588 then case t1 of 589 S.IntConst n1 -> if S.isValue t2 590 then case t2 of 591 S.IntConst n2 -> Just (S.IntConst (I.intNand n1 n2)) 592 _ -> Nothing 593 else case eval1 t2 of 594 Just t2' -> Just (S.IntNand t1 t2') 595 Nothing -> Nothing 596 _ -> Nothing 597 else case eval1 t1 of 598 Just t1' -> Just (S.IntNand t1' t2) 599 Nothing -> Nothing 600 601eval1 (S.IntEq t1 t2) = 602 if S.isValue t1 603 then case t1 of 604 S.IntConst n1 -> if S.isValue t2 605 then case t2 of 606 S.IntConst n2 -> case I.intEq n1 n2 of 607 True -> Just S.Tru 608 _ -> Just S.Fls 609 _ -> Nothing 610 else case eval1 t2 of 611 Just t2' -> Just (S.IntEq t1 t2') 612 Nothing -> Nothing 613 _ -> Nothing 614 else case eval1 t1 of 615 Just t1' -> Just (S.IntEq t1' t2) 616 Nothing -> Nothing 617 618eval1 (S.IntLt t1 t2) = 619 if S.isValue t1 620 then case t1 of 621 S.IntConst n1 -> if S.isValue t2 622 then case t2 of 623 S.IntConst n2 -> case I.intLt n1 n2 of 624 True -> Just S.Tru 625 _ -> Just S.Fls 626 _ -> Nothing 627 else case eval1 t2 of 628 Just t2' -> Just (S.IntLt t1 t2') 629 Nothing -> Nothing 630 _ -> Nothing 631 else case eval1 t1 of 632 Just t1' -> Just (S.IntLt t1' t2) 633 Nothing -> Nothing 634 635-- All other cases 636eval1 _ = Nothing 637 638eval :: S.Term -> S.Term 639eval t = 640 case eval1 t of 641 Just t' -> eval t' 642 Nothing -> t 643 644\end{code} 645\section{Arithmetic} 646The module $\mathit{IntegerArithmetic}$ formalizes the $\mathit{primitive}$ operators for integer arithmetic. In a nutshell, even though we use the Haskell infinite-precision type Integer to store integers, the numbers are really only using the 32-bit 2's complement range, and arithmetic operations must work accordingly. Roughly speaking, arithmetic is as in C on a 32-bit machine. Complete the code. 647 648\begin{code} 649 650module IntegerArithmetic where 651import Data.Bits 652 653intRestrictRangeAddMul :: Integer -> Integer 654intRestrictRangeAddMul m = m `mod` 4294967296 655 656intAdd :: Integer -> Integer -> Integer 657intAdd m n = intRestrictRangeAddMul (m + n) 658 659intSub :: Integer -> Integer -> Integer 660intSub m n = m - n 661 662intMul :: Integer -> Integer -> Integer 663intMul m n = intRestrictRangeAddMul (m * n) 664 665intDiv :: Integer -> Integer -> Integer 666intDiv m n = if n == 0 then error "integer division by zero" else m `div` n 667 668intNand :: Integer -> Integer -> Integer 669intNand m n = complement (m .&. n) 670 671intEq :: Integer -> Integer -> Bool 672intEq m n = m == n 673 674intLt :: Integer -> Integer -> Bool 675intLt m n = m < n 676 677\end{code} 678 679 680\section{Type Checker} 681It is always good to be sure a program is well-typed before we try to evaluate it. You can use the following type checker or write your own. 682 683\begin{code} 684module Typing where 685import qualified AbstractSyntax as S 686import List 687data Context = Empty 688 | Bind Context S.Var S.Type 689 deriving Eq 690instance Show Context where 691 show Empty = "<>" 692 show (Bind capGamma x tau) = show capGamma ++ "," ++ x ++ ":" ++ show tau 693 694contextLookup :: S.Var -> Context -> Maybe S.Type 695contextLookup x Empty = Nothing 696contextLookup x (Bind capGamma y tau) 697 | x == y = Just tau 698 | otherwise = contextLookup x capGamma 699 700typing :: Context -> S.Term -> Maybe S.Type 701--T-Var 702typing capGamma (S.Var x) = contextLookup x capGamma 703--T-Abs 704typing capGamma (S.Abs x tau_1 t2) = case typing (Bind capGamma x tau_1) t2 of 705 Just(tp0) -> Just (S.TypeArrow tau_1 tp0) 706 Nothing -> Nothing 707typing capGamma (S.App t0 t2)= 708 case typing capGamma t0 of 709 Just (S.TypeArrow tp tp0) -> case typing capGamma t2 of 710 Just tp' -> if tp==tp' 711 then Just tp0 712 else Nothing 713 Nothing -> Nothing 714 _ -> Nothing 715 716--T-True 717typing capGamma S.Tru = Just S.TypeBool 718 719--T-False 720typing capGamma S.Fls = Just S.TypeBool 721 722--T-If 723typing capGamma (S.If t0 t2 t3) 724 | (typing capGamma t2 == typing capGamma t3 && typing capGamma t0 == Just S.TypeBool) = typing capGamma t2 725 | otherwise = Nothing 726 727typing capGamma (S.IntConst _) = Just S.TypeInt 728 729--T-IntAdd 730typing capGamma (S.IntAdd t1 t2) = 731 case typing capGamma t1 of 732 Just S.TypeInt -> case typing capGamma t1 of 733 Just S.TypeInt -> Just S.TypeInt 734 Nothing -> Nothing 735--T-IntSub 736typing capGamma (S.IntSub t1 t2) = 737 case typing capGamma t1 of 738 Just S.TypeInt -> case typing capGamma t1 of 739 Just S.TypeInt -> Just S.TypeInt 740 Nothing -> Nothing 741--T-IntMul 742typing capGamma (S.IntMul t1 t2) = 743 case typing capGamma t1 of 744 Just S.TypeInt -> case typing capGamma t1 of 745 Just S.TypeInt -> Just S.TypeInt 746 Nothing -> Nothing 747--T-IntDiv 748typing capGamma (S.IntDiv t1 t2) = 749 case typing capGamma t1 of 750 Just S.TypeInt -> case typing capGamma t1 of 751 Just S.TypeInt -> Just S.TypeInt 752 Nothing -> Nothing 753--T-IntNand 754typing capGamma (S.IntNand t1 t2) = 755 case typing capGamma t1 of 756 Just S.TypeInt -> case typing capGamma t1 of 757 Just S.TypeInt -> Just S.TypeInt 758 Nothing -> Nothing 759--T-IntEq 760typing capGamma (S.IntEq t1 t2) = 761 case typing capGamma t1 of 762 Just S.TypeBool -> case typing capGamma t1 of 763 Just S.TypeBool -> Just S.TypeBool 764 Nothing -> Nothing 765--T-IntLt 766typing capGamma (S.IntLt t1 t2) = 767 case typing capGamma t1 of 768 Just S.TypeBool -> case typing capGamma t1 of 769 Just S.TypeBool -> Just S.TypeInt 770 Nothing -> Nothing 771typeCheck :: S.Term -> S.Type 772typeCheck t = 773 case typing Empty t of 774 Just tau -> tau 775 _ -> error "type error" 776\end{code} 777 778\section{Main Program} 779Write a main program which will (1) read the program text from a file into a string, (2) invoke the parser 780to produce an abstract syntax tree for the program, (3) type-check the program, and (4) evaluate the 781program using the small-step evaluation relation. 782 783\begin{code} 784module Main where 785 786import qualified System.Environment 787import Data.List 788import IO 789import qualified AbstractSyntax as S 790import qualified StructuralOperationalSemantics as E 791import qualified NaturalSemantics as N 792import qualified IntegerArithmetic as I 793import qualified Typing as T 794 795main :: IO() 796main = 797 do 798 args <- System.Environment.getArgs 799 let [sourceFile] = args 800 source <- readFile sourceFile 801 let tokens = S.scan source 802 let term = S.parse tokens 803 putStrLn ("----Term----") 804 putStrLn (show term) 805 putStrLn ("----Type----") 806 putStrLn (show (T.typeCheck term)) 807 putStrLn ("----Normal Form in Structureal Operational Semantics----") 808 putStrLn (show (E.eval term)) 809 putStrLn ("----Normal Form of Natural Semantics----") 810 putStrLn (show (N.eval term)) 811\end{code} 812 813\section{Structural Operational Semantics} 814 815\paragraph{} 816Formally stating the rules that give the structural operational semantics of the core lambda language, the rules are listed below: 817\[ 818 \text{if true then } t_2 \text{ else } t_3 \rightarrow t_2 \text{\quad (\textsc{E-IfTrue})} 819\] 820\ \\ 821\[ 822 \text{if false then } t_2 \text{ else } t_3 \rightarrow t_3 \text{(\quad \textsc{E-IfFalse})} 823\] 824\ \\ 825\[ 826 \frac{t_1 \rightarrow t'_1}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \rightarrow \text{if } t'_1 \text{ then } t_2 \text{ else} t_3} \text{\quad (\textsc{E-If})} 827\] 828\ \\ 829\[ 830 \frac{t_1 \rightarrow t'_1}{t_1 \text{\ } t_2 \rightarrow t'_1 \text{\ } t_2}\text{\quad {\textsc{E-App1}}} 831\] 832\ \\ 833\[ 834 \frac{t_2 \rightarrow t'_2}{t_1 \text{\ } t_2 \rightarrow t_1 \text{\ } t'_2}\text{\quad {\textsc{E-App2}}} 835\] 836\ \\ 837\[ 838 (\lambda x: T_{11}.t_{12})v_2 \rightarrow [ x \mapsto v_2 ] _{12} \text{\quad (\textsc{E-AppAbs})} 839\] 840\ \\ 841\[ 842 \frac{t_1 \rightarrow t'_1}{+(t_1, t_2) \rightarrow +(t'_1, t_2)} \text{\quad (\textsc{E-IntAdd1})} 843\] 844\ \\ 845\[ 846 \frac{t_2 \rightarrow t'_2}{+(t_1, t_2) \rightarrow +(t_1, t'_2)} \text{\quad (\textsc{E-IntAdd2})} 847\] 848\ \\ 849\[ 850 +(v_1, v_2) \rightarrow v_1 \widetilde{+} v_2 \text{\quad (\textsc{E-IntAppAdd})} 851\] 852\ \\ 853\[ 854 \frac{t_1 \rightarrow t'_1}{-(t_1, t_2) \rightarrow -(t'_1, t_2)} \text{\quad (\textsc{E-IntSub1})} 855\] 856\ \\ 857\[ 858 \frac{t_2 \rightarrow t'_2}{-(t_1, t_2) \rightarrow -(t_1, t'_2)} \text{\quad (\textsc{E-IntSub2})} 859\] 860\ \\ 861\[ 862 -(v_1, v_2) \rightarrow v_1 \widetilde{-} v_2 \text{\quad (\textsc{E-AppIntSub})} 863\] 864\ \\ 865\[ 866 \frac{t_1 \rightarrow t'_1}{*(t_1, t_2) \rightarrow *(t'_1, t_2)} \text{\quad (\textsc{E-IntMul1})} 867\] 868\ \\ 869\[ 870 \frac{t_2 \rightarrow t'_2}{*(t_1, t_2) \rightarrow *(t_1, t'_2)} \text{\quad (\textsc{E-IntMul2})} 871\] 872\ \\ 873\[ 874 *(v_1, v_2) \rightarrow v_1 \widetilde{*} v_2 \text{\quad (\textsc{E-AppIntMul})} 875\] 876\ \\ 877\[ 878 \frac{t_1 \rightarrow t'_1}{/(t_1, t_2) \rightarrow /(t'_1, t_2)} \text{\quad (\textsc{E-IntDiv1})} 879\] 880\ \\ 881\[ 882 \frac{t_2 \rightarrow t'_2}{/(t_1, t_2) \rightarrow /(t_1, t'_2)} \text{\quad (\textsc{E-IntDiv2})} 883\] 884\ \\ 885\[ 886 /(v_1, v_2) \rightarrow v_1 \widetilde{/} v_2 \text{\quad (\textsc{E-AppIntDiv})} 887\] 888\ \\ 889\[ 890 \frac{t_1 \rightarrow t'_1}{\wedge(t_1, t_2) \rightarrow \wedge(t'_1, t_2)} \text{\quad (\textsc{E-IntNand1})} 891\] 892\ \\ 893\[ 894 \frac{t_2 \rightarrow t'_2}{\wedge(t_1, t_2) \rightarrow \wedge(t_1, t'_2)} \text{\quad (\textsc{E-IntNand2})} 895\] 896\ \\ 897\[ 898 \wedge(v_1, v_2) \rightarrow v_1 \widetilde{\wedge} v_2 \text{\quad (\textsc{E-AppIntNand})} 899\] 900\ \\ 901\[ 902 \frac{t_1 \rightarrow t'_1}{=(t_1, t_2) \rightarrow =(t'_1, t_2)} \text{\quad (\textsc{E-IntEq1})} 903\] 904\ \\ 905\[ 906 \frac{t_2 \rightarrow t'_2}{=(t_1, t_2) \rightarrow =(t_1, t'_2)} \text{\quad (\textsc{E-IntEq2})} 907\] 908\ \\ 909\[ 910 =(v_1, v_2) \rightarrow v_1 \widetilde{\equiv} v_2 \text{\quad (\textsc{E-AppIntEq})} 911\] 912\ \\ 913\[ 914 \frac{t_1 \rightarrow t'_1}{<(t_1, t_2) \rightarrow <(t'_1, t_2)} \text{\quad (\textsc{E-IntLt1})} 915\] 916\ \\ 917\[ 918 \frac{t_2 \rightarrow t'_2}{<(t_1, t_2) \rightarrow <(t_1, t'_2)} \text{\quad (\textsc{E-IntLt2})} 919\] 920\ \\ 921\[ 922 <(v_1, v_2) \rightarrow v_1 \widetilde{<} v_2 \text{\quad (\textsc{E-AppIntLt})} 923\] 924\ \\ 925where 926\begin{align*} 927 \widetilde{+} &\text{\quad \quad is the funtion that adds the two arguments and returns an Integer result}\\ 928 \widetilde{-} &\text{\quad \quad is the function that subtracts the two arguments and returns an Integer result}\\ 929 \widetilde{*} &\text{\quad \quad is the function that times the two arguments and returns an Integer result}\\ 930 \widetilde{/} &\text{\quad \quad is the function that divides the two arguments and returns an Integer result}\\ 931 \widetilde{\wedge} &\text{\quad \quad is the function that gets the nand result of the two arguments and returns it }\\ 932 \widetilde{\equiv} &\text{\quad \quad is the function that judges whether the two values are equal. If so, returns \textbf{true}, otherwise \textbf{false}}\\ 933 \widetilde{<} &\text{\quad \quad is the function that judges whether the first value is less than the second one.} \\ 934 &\text{\quad \quad \ If so, returns \textbf{true}, otherwise \textbf{false}} 935\end{align*} 936 937 938 939 940 941\section{Natural Semantics} 942 943\paragraph{} 944Formally state the rules that give the natural semantics (big-step operational semantics) of the core lambda language. (Note: here we mean the version of natural semantics that operates on terms and performs substitutions, rather than the version with environments.) 945 946\paragraph{} 947The formal rules of the natural semantics for this programming language is as follows: 948\[ 949 a\Downarrow v \text{\quad (\textsc{B-ClosedForm})} 950\] 951for closed form $a$, and $a$ should have no free variable inside. 952\[ 953 v \Downarrow v \text{\quad (\textsc{B-Value})} 954\] 955\ \\ 956\[ 957 \frac{a\Downarrow \lambda x.a'\text{\quad} b\Downarrow v'\text{\quad} [x\mapsto v']a'\Downarrow v}{a\text{\ }b \Downarrow v}\text{\quad (\textsc{B-App})} 958\] 959\ \\ 960\[ 961 \frac{t_1 \Downarrow \text{ true\quad } t_2 \Downarrow v_2}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \Downarrow v_2}\text{\quad (\textsc{B-IfTrue})} 962\] 963\ \\ 964\[ 965 \frac{t_1 \Downarrow \text{ false\quad} t_3 \Downarrow v_3}{\text{if } t_1 \text{ then } t_2 \text{ else } t_3 \Downarrow v_3}\text{\quad (\textsc{B-IfFalse})} 966\] 967\ \\ 968\[ 969 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{+}(v_1, v_2)}{+(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntAdd})} 970\] 971\ \\ 972\[ 973 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{-}(v_1, v_2)}{-(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntSub})} 974\] 975\ \\ 976\[ 977 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{*}(v_1, v_2)}{*(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntMul})} 978\] 979\ \\ 980\[ 981 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{/}(v_1, v_2)}{/(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntDiv})} 982\] 983\ \\ 984\[ 985 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{\wedge}(v_1, v_2)}{\wedge(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntNand})} 986\] 987\ \\ 988\[ 989 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{=}(v_1, v_2)}{=(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntEq})} 990\] 991\ \\ 992\[ 993 \frac{t_1 \Downarrow v_1\text{\quad} t_2 \Downarrow v_2\text{\quad} v = \widetilde{<}(v_1, v_2)}{<(t_1, t_2) \Downarrow v}\text{\quad (\textsc{B-IntLt})} 994\] 995\ \\ 996\section{Natural Semantics} 997 998\paragraph{} 999Express the natural semantics in Haskell code, as an interpreter for lambda terms given by the Haskell function \textit{eval::Term $\rightarrow$ Term} in a module \textit{NaturalSemantics}. The completed module source code is as follows: 1000 1001\begin{code} 1002module NaturalSemantics where 1003 1004import List 1005import qualified AbstractSyntax as S 1006import qualified IntegerArithmetic as I 1007 1008eval :: S.Term -> S.Term 1009 1010eval (S.If t1 t2 t3) = 1011 case eval t1 of 1012 S.Tru -> eval t2 -- B-IfTrue 1013 S.Fls -> eval t3 -- B-IfFalse 1014 _ -> S.If t1 t2 t3 1015 1016-- B-App 1017eval (S.App t1 t2) = 1018 if (S.isValue $ eval t1) 1019 then case eval t1 of 1020 S.Abs x tau t11 -> if ((S.isValue $ eval t2) && ((S.fv (S.Abs x tau t11)) == [])) 1021 then eval (S.subst x (eval t2) t11) 1022 else S.App t1 t2 1023 _ -> S.App t1 t2 1024 else S.App t1 t2 1025 1026-- B-IntAdd 1027eval (S.IntAdd t1 t2) = 1028 case eval t1 of 1029 S.IntConst v1 -> case eval t2 of 1030 S.IntConst v2 -> S.IntConst (I.intAdd v1 v2) 1031 _ -> S.IntAdd t1 t2 1032 _ -> S.IntAdd t1 t2 1033 1034 1035-- B-IntSub 1036eval (S.IntSub t1 t2) = 1037 case eval t1 of 1038 S.IntConst v1 -> case eval t2 of 1039 S.IntConst v2 -> S.IntConst (I.intSub v1 v2) 1040 _ -> S.IntSub t1 t2 1041 _ -> S.IntSub t1 t2 1042 1043-- B-IntMul 1044eval (S.IntMul t1 t2) = 1045 case eval t1 of 1046 S.IntConst v1 -> case eval t2 of 1047 S.IntConst v2 -> S.IntConst (I.intMul v1 v2) 1048 _ -> S.IntSub t1 t2 1049 _ -> S.IntSub t1 t2 1050 1051-- B-IntDiv 1052eval (S.IntDiv t1 t2) = 1053 case eval t1 of 1054 S.IntConst v1 -> case eval t2 of 1055 S.IntConst v2 -> S.IntConst (I.intDiv v1 v2) 1056 _ -> S.IntDiv t1 t2 1057 _ -> S.IntDiv t1 t2 1058 1059-- B-IntNand 1060eval (S.IntNand t1 t2) = 1061 case eval t1 of 1062 S.IntConst v1 -> case eval t2 of 1063 S.IntConst v2 -> S.IntConst (I.intNand v1 v2) 1064 _ -> S.IntNand t1 t2 1065 _ -> S.IntNand t1 t2 1066 1067-- B-IntEq 1068eval (S.IntEq t1 t2) = 1069 case eval t1 of 1070 S.IntConst v1 -> case eval t2 of 1071 S.IntConst v2 -> case I.intEq v1 v2 of 1072 True -> S.Tru 1073 False -> S.Fls 1074 _ -> S.IntEq t1 t2 1075 _ -> S.IntEq t1 t2 1076 1077-- B-IntLt 1078eval (S.IntLt t1 t2) = 1079 case eval t1 of 1080 S.IntConst v1 -> case eval t2 of 1081 S.IntConst v2 -> case I.intLt v1 v2 of 1082 True -> S.Tru 1083 False -> S.Fls 1084 _ -> S.IntLt t1 t2 1085 _ -> S.IntLt t1 t2 1086 1087-- B-Value and Exceptions 1088eval t = t 1089 1090\end{code} 1091 1092\section{Test Cases} 1093 1094\subsection{Test 1} 1095\verbatiminput{test1.TLBN} 1096\verbatiminput{test1.out} 1097 1098\subsection{Test 2} 1099\verbatiminput{test2.TLBN} 1100\verbatiminput{test2.out} 1101 1102\subsection{Test 3} 1103\verbatiminput{test3.TLBN} 1104\verbatiminput{test3.out} 1105 1106\subsection{Test 4} 1107\verbatiminput{test4.TLBN} 1108\verbatiminput{test4.out} 1109 1110\subsection{Test 5} 1111\verbatiminput{test5.TLBN} 1112\verbatiminput{test5.out} 1113 1114\subsection{Test 6} 1115\verbatiminput{test6.TLBN} 1116\verbatiminput{test6.out} 1117 1118\subsection{Test 7} 1119\verbatiminput{test7.TLBN} 1120\verbatiminput{test7.out} 1121 1122\subsection{Test 8} 1123\verbatiminput{test8.TLBN} 1124\verbatiminput{test8.out} 1125 1126\subsection{Test 9} 1127\verbatiminput{test9.TLBN} 1128\verbatiminput{test9.out} 1129 1130\subsection{Test 10} 1131\verbatiminput{test10.TLBN} 1132\verbatiminput{test10.out} 1133\end{document}