Skip to content

Instantly share code, notes, and snippets.

@jda0

jda0/part1.txt

Created January 22, 2019 12:37
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jda0/2b7a283aa394383215d163da6911cd87 to your computer and use it in GitHub Desktop.
Save jda0/2b7a283aa394383215d163da6911cd87 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
part1.txt
Preliminary notes:
1. Where necessary the following function was used to convert parser output to
canonical form (to detect equivalent syntax trees up to associativity of
statement composition):
tx :: Stm -> Stm
tx (Comp (Comp a b) c) = tx (Comp a (Comp b c))
tx (Comp a b) = (Comp (tx a) (tx b))
tx (If b s1 s2) = (If b (tx s1) (tx s2))
tx (While b s) = (While b (tx s))
tx (Block dv dp s) = Block dv dp (tx s)
tx s = s
2. If your submission was already a module, the filename has automatically been
changed to <MODULE_NAME>.hs to allow it to be found by the automarker.
================================================================================
Test description: Skip statement
Input file: 1-skip.w...PASS (1/1 marks)
---
Test description: Single and multi-line comments
Input file: 2-comments.w...PASS (1/1 marks)
---
Test description: Ass with N
Input file: 3-ass-n.w...PASS (1/1 marks)
---
Test description: Ass with lowercase alphabetical identifiers
Input file: 4-ass-v.w...PASS (1/1 marks)
---
Test description: Ass with lowercase alphanumeric identifiers
Input file: 5-ass-v-alphanum.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Add
Input file: 6-ass-add.w...FAIL (0/1 marks)
Expected output:
Comp (Ass "x" (Add (N 1) (N 5))) (Comp (Ass "y" (Add (Add (Add (Add (Add (N 4) (N 7)) (N 34)) (N 32)) (N 147)) (N 42))) (Ass "z" (Add (Add (Add (Add (N 333) (N 27)) (N 0)) (N 7)) (N 8))))
Actual output:
Comp (Ass "x" (Add (N 1) (N 5))) (Comp (Ass "y" (Add (N 4) (Add (N 7) (Add (N 34) (Add (N 32) (Add (N 147) (N 42))))))) (Ass "z" (Add (N 333) (Add (N 27) (Add (N 0) (Add (N 7) (N 8)))))))
---
Test description: Ass with bracketed Add
Input file: 7-ass-add-b.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Sub
Input file: 8-ass-sub.w...FAIL (0/1 marks)
Expected output:
Comp (Ass "x" (Sub (Sub (Sub (Sub (N 100) (N 5)) (N 7)) (N 4)) (N 2))) (Comp (Ass "y" (Sub (Sub (Sub (Sub (N 654) (N 43)) (N 12)) (N 0)) (N 145))) (Ass "z" (Sub (N 7) (N 2))))
Actual output:
Comp (Ass "x" (Sub (N 100) (Sub (N 5) (Sub (N 7) (Sub (N 4) (N 2)))))) (Comp (Ass "y" (Sub (N 654) (Sub (N 43) (Sub (N 12) (Sub (N 0) (N 145)))))) (Ass "z" (Sub (N 7) (N 2))))
---
Test description: Ass with bracketed Sub
Input file: 9-ass-sub-b.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Mult
Input file: 10-ass-mult.w...FAIL (0/1 marks)
Expected output:
Comp (Ass "x" (Mult (Mult (Mult (Mult (Mult (Mult (Mult (N 5) (N 6)) (N 7)) (N 8)) (N 9)) (N 10)) (N 11)) (N 12))) (Comp (Ass "y" (Mult (Mult (N 4) (N 7)) (N 3))) (Ass "z" (Mult (N 333) (N 27))))
Actual output:
Comp (Ass "x" (Mult (N 5) (Mult (N 6) (Mult (N 7) (Mult (N 8) (Mult (N 9) (Mult (N 10) (Mult (N 11) (N 12))))))))) (Comp (Ass "y" (Mult (N 4) (Mult (N 7) (N 3)))) (Ass "z" (Mult (N 333) (N 27))))
---
Test description: Ass with bracketed Mult
Input file: 11-ass-mult-b.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Aexp
Input file: 12-ass.w...FAIL (0/3 marks)
Expected output:
Comp (Ass "a" (N 9)) (Comp (Ass "b" (N 17)) (Comp (Ass "c" (N 13)) (Comp (Ass "d" (Add (V "a") (V "b"))) (Comp (Ass "e" (Sub (V "c") (V "a"))) (Comp (Ass "f" (Mult (V "b") (V "c"))) (Comp (Ass "g" (Add (N 1) (V "f"))) (Comp (Ass "h" (Add (V "g") (N 7))) (Comp (Ass "i" (Add (Add (Add (V "a") (V "b")) (V "c")) (V "d"))) (Comp (Ass "j" (Sub (Sub (V "d") (V "c")) (V "a"))) (Comp (Ass "k" (Mult (Mult (Mult (V "a") (V "b")) (V "c")) (V "d"))) (Comp (Ass "l" (Sub (Add (V "a") (V "g")) (Mult (V "c") (V "e")))) (Comp (Ass "m" (Sub (Add (Mult (V "a") (V "b")) (V "c")) (V "d"))) (Comp (Ass "n" (Add (Sub (V "h") (Mult (V "b") (V "c"))) (V "d"))) (Comp (Ass "o" (Add (Add (Add (Add (Sub (Add (Sub (Add (Sub (Add (V "a") (V "b")) (V "c")) (Mult (N 2) (V "d"))) (V "e")) (V "f")) (Mult (N 7) (V "g"))) (V "h")) (N 5)) (Mult (Mult (V "i") (V "j")) (V "k"))) (V "l"))) (Ass "p" (V "o"))))))))))))))))
Actual output:
Comp (Ass "a" (N 9)) (Comp (Ass "b" (N 17)) (Comp (Ass "c" (N 13)) (Comp (Ass "d" (Add (V "a") (V "b"))) (Comp (Ass "e" (Sub (V "c") (V "a"))) (Comp (Ass "f" (Mult (V "b") (V "c"))) (Comp (Ass "g" (Add (N 1) (V "f"))) (Comp (Ass "h" (Add (V "g") (N 7))) (Comp (Ass "i" (Add (V "a") (Add (V "b") (Add (V "c") (V "d"))))) (Comp (Ass "j" (Sub (V "d") (Sub (V "c") (V "a")))) (Comp (Ass "k" (Mult (V "a") (Mult (V "b") (Mult (V "c") (V "d"))))) (Comp (Ass "l" (Add (V "a") (Sub (V "g") (Mult (V "c") (V "e"))))) (Comp (Ass "m" (Add (Mult (V "a") (V "b")) (Sub (V "c") (V "d")))) (Comp (Ass "n" (Sub (V "h") (Add (Mult (V "b") (V "c")) (V "d")))) (Comp (Ass "o" (Add (V "a") (Sub (V "b") (Add (V "c") (Sub (Mult (N 2) (V "d")) (Add (V "e") (Sub (V "f") (Add (Mult (N 7) (V "g")) (Add (V "h") (Add (N 5) (Add (Mult (V "i") (Mult (V "j") (V "k"))) (V "l")))))))))))) (Ass "p" (V "o"))))))))))))))))
---
Test description: Ass with bracketed Aexp
Input file: 13-ass-b.w...PASS (3/3 marks)
---
Test description: Test whether correct version of “false” used (i.e. not “FALSE” or “False”)
Input file: 14-if-true.w...PASS (1/1 marks)
---
Test description: Test whether correct version of “true” used (i.e. not “TRUE” or “True”)
Input file: 15-if-false.w...PASS (1/1 marks)
---
Test description: Nested If with Le
Input file: 16-if-le-nest.w...PASS (1/1 marks)
---
Test description: Nested If with Eq
Input file: 17-if-eq-nest.w...PASS (1/1 marks)
---
Test description: Nested If with Neg
Input file: 18-if-neg-nest.w...PASS (1/1 marks)
---
Test description: Nested If with left-associative And
Input file: 19-if-and-nest.w...FAIL (0/1 marks)
Expected output:
If (And TRUE TRUE) (Ass "x" (N 1)) (If (And (And TRUE TRUE) TRUE) (Ass "y" (N 3)) (If (And (And FALSE TRUE) FALSE) (Ass "z" (N 5)) (If (And FALSE FALSE) (Ass "a" (N 7)) (Ass "a" (N 8)))))
Actual output:
If (And TRUE TRUE) (Ass "x" (N 1)) (If (And TRUE (And TRUE TRUE)) (Ass "y" (N 3)) (If (And FALSE (And TRUE FALSE)) (Ass "z" (N 5)) (If (And FALSE FALSE) (Ass "a" (N 7)) (Ass "a" (N 8)))))
---
Test description: Nested If with Bexp
Input file: 20-if-nest.w...FAIL (0/4 marks)
Expected output:
If (Le (N 1) (N 2)) (Ass "a" (N 1)) (If (Le (N 4) (N 3)) (Ass "b" (N 3)) (If (Eq (N 5) (N 5)) (Ass "c" (N 5)) (If (Eq (N 6) (N 7)) (Ass "d" (N 7)) (If (Neg (Eq (N 8) (N 9))) (Ass "e" (N 9)) (If (Neg (Eq (N 10) (N 10))) (Ass "f" (N 11)) (If (And (Le (N 11) (N 12)) (Le (N 13) (N 14))) (Ass "g" (N 13)) (If (And (Le (N 15) (N 16)) (Le (N 18) (N 17))) (Ass "h" (N 15)) (If (And (Neg (Le (N 20) (N 19))) (Eq (N 21) (N 21))) (Ass "i" (N 17)) (If (And (And (Neg (Eq (N 22) (N 23))) (Le (N 24) (N 25))) (Neg (Eq (N 26) (N 26)))) (Ass "j" (N 17)) (Ass "j" (N 18)))))))))))
Actual output:
If (Le (N 1) (N 2)) (Ass "a" (N 1)) (If (Le (N 4) (N 3)) (Ass "b" (N 3)) (If (Eq (N 5) (N 5)) (Ass "c" (N 5)) (If (Eq (N 6) (N 7)) (Ass "d" (N 7)) (If (Neg (Eq (N 8) (N 9))) (Ass "e" (N 9)) (If (Neg (Eq (N 10) (N 10))) (Ass "f" (N 11)) (If (And (Le (N 11) (N 12)) (Le (N 13) (N 14))) (Ass "g" (N 13)) (If (And (Le (N 15) (N 16)) (Le (N 18) (N 17))) (Ass "h" (N 15)) (If (And (Neg (Le (N 20) (N 19))) (Eq (N 21) (N 21))) (Ass "i" (N 17)) (If (And (Neg (Eq (N 22) (N 23))) (And (Le (N 24) (N 25)) (Neg (Eq (N 26) (N 26))))) (Ass "j" (N 17)) (Ass "j" (N 18)))))))))))
---
Test description: Bracketed If with Le
Input file: 21-if-le-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Eq
Input file: 22-if-eq-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Neg
Input file: 23-if-neg-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with And
Input file: 24-if-and-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Bexp
Input file: 25-if-b.w...PASS (4/4 marks)
---
Test description: Nested While with Le
Input file: 26-while-le-nest.w...PASS (1/1 marks)
---
Test description: Nested While with Eq
Input file: 27-while-eq-nest.w...PASS (1/1 marks)
---
Test description: Nested While with Neg
Input file: 28-while-neg-nest.w...PASS (1/1 marks)
---
Test description: Nested While with left-associative And
Input file: 29-while-and-nest.w...PASS (1/1 marks)
---
Test description: Bracketed While with Le
Input file: 30-while-le-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Eq
Input file: 31-while-eq-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Neg
Input file: 32-while-neg-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with And
Input file: 33-while-and-b.w...PASS (1/1 marks)
---
Test description: Nested While with Bexp
Input file: 34-while-nest.w...PASS (4/4 marks)
---
Test description: Bracketed While with Bexp
Input file: 35-while-b.w...PASS (4/4 marks)
---
Test description: Block procedure declarations (alphanumeric identifiers)
Input file: 36-block-dp-alphanum.w...PASS (1/1 marks)
---
Test description: Block variable declarations
Input file: 37-block-dv.w...PASS (3/3 marks)
---
Test description: Block procedure declarations (alphabetic identifiers)
Input file: 38-block-dp.w...PASS (2/2 marks)
---
Test description: Block with simple statement
Input file: 39-block-skip.w...PASS (1/1 marks)
---
Test description: Nested blocks
Input file: 40-block-skips.w...PASS (1/1 marks)
---
Test description: Call statements
Input file: 41-call.w...PASS (1/1 marks)
---
Test description: Factorial program – iterative version
Input file: 42-fact-iter.w...PASS (6/6 marks)
---
Test description: Factorial program – recursive version
Input file: 43-fact-rec.w...PASS (10/10 marks)
---
Test description: Simple mutual recursion program with brackets final proc
Input file: 44-mutual2-b.w...PASS (2/2 marks)
---
Test description: Simple mutual recursion program without brackets on final proc
Input file: 45-mutual2.w...FAIL (0/6 marks)
Expected output:
Block [] [("p",If (Le (N 1) (V "x")) (Comp (Ass "x" (Sub (V "x") (N 1))) (Call "q")) Skip),("q",If (Le (N 1) (V "x")) (Comp (Ass "x" (Sub (V "x") (N 1))) (Call "p")) Skip)] (Call "p")
Actual output:
No valid parse found. Printing GHCI output:
GHCi, version 8.0.2: http://www.haskell.org/ghc/ :? for help
[1 of 1] Compiling Proc ( Proc.hs, interpreted )
Ok, modules loaded: Proc.
*Proc> *** Exception: Maybe.fromJust: Nothing
*Proc> Leaving GHCi.
---
Test description: Mutual recursion program based on J. Terry’s forum post
Input file: 46-mutual.w...FAIL (0/10 marks)
Expected output:
Block [("x",N 5)] [("a",If (Neg (Le (V "x") (N 3))) (Comp (Ass "y" (Add (V "y") (N 1))) (Comp (Ass "x" (Sub (V "x") (N 1))) (Call "b"))) Skip),("b",Comp (Ass "y" (Add (V "y") (N 100))) (Call "a"))] (Comp (Block [("x",N 6)] [("a",Ass "x" (N 50))] (Comp (Ass "y" (N 0)) (Comp (Call "b") (Ass "xinner" (V "x"))))) (Ass "xouter" (V "x")))
Actual output:
No valid parse found. Printing GHCI output:
GHCi, version 8.0.2: http://www.haskell.org/ghc/ :? for help
[1 of 1] Compiling Proc ( Proc.hs, interpreted )
Ok, modules loaded: Proc.
*Proc> *** Exception: Maybe.fromJust: Nothing
*Proc> Leaving GHCi.
---
Test description: Procedure scoping example program
Input file: 47-scope.w...PASS (6/6 marks)
---
total part2 mark: 73
Raw
part2.txt
Test description: Ass with N
[dynamic] Input file: 3-ass-n.w...PASS (1/1 marks)
[mixed] Input file: 3-ass-n.w...PASS (1/1 marks)
[static] Input file: 3-ass-n.w...PASS (1/1 marks)
---
Test description: Ass with lowercase alphabetical identifiers
[dynamic] Input file: 4-ass-v.w...PASS (1/1 marks)
[mixed] Input file: 4-ass-v.w...PASS (1/1 marks)
[static] Input file: 4-ass-v.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Add
[dynamic] Input file: 6-ass-add.w...PASS (1/1 marks)
[mixed] Input file: 6-ass-add.w...PASS (1/1 marks)
[static] Input file: 6-ass-add.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Sub
[dynamic] Input file: 8-ass-sub.w...PASS (1/1 marks)
[mixed] Input file: 8-ass-sub.w...PASS (1/1 marks)
[static] Input file: 8-ass-sub.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Mult
[dynamic] Input file: 10-ass-mult.w...PASS (1/1 marks)
[mixed] Input file: 10-ass-mult.w...PASS (1/1 marks)
[static] Input file: 10-ass-mult.w...PASS (1/1 marks)
---
Test description: Ass with left-associative Aexp
[dynamic] Input file: 12-ass.w...PASS (1/1 marks)
[mixed] Input file: 12-ass.w...PASS (1/1 marks)
[static] Input file: 12-ass.w...PASS (1/1 marks)
---
Test description: Test whether correct version of “false” used (i.e. not “FALSE” or “False”)
[dynamic] Input file: 14-if-true.w...PASS (1/1 marks)
[mixed] Input file: 14-if-true.w...PASS (1/1 marks)
[static] Input file: 14-if-true.w...PASS (1/1 marks)
---
Test description: Test whether correct version of “true” used (i.e. not “TRUE” or “True”)
[dynamic] Input file: 15-if-false.w...PASS (1/1 marks)
[mixed] Input file: 15-if-false.w...PASS (1/1 marks)
[static] Input file: 15-if-false.w...PASS (1/1 marks)
---
Test description: Nested If with Bexp
[dynamic] Input file: 20-if-nest.w...PASS (1/1 marks)
[mixed] Input file: 20-if-nest.w...PASS (1/1 marks)
[static] Input file: 20-if-nest.w...PASS (1/1 marks)
---
Test description: Bracketed If with Le
[dynamic] Input file: 21-if-le-b.w...PASS (1/1 marks)
[mixed] Input file: 21-if-le-b.w...PASS (1/1 marks)
[static] Input file: 21-if-le-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Eq
[dynamic] Input file: 22-if-eq-b.w...PASS (1/1 marks)
[mixed] Input file: 22-if-eq-b.w...PASS (1/1 marks)
[static] Input file: 22-if-eq-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Neg
[dynamic] Input file: 23-if-neg-b.w...PASS (1/1 marks)
[mixed] Input file: 23-if-neg-b.w...PASS (1/1 marks)
[static] Input file: 23-if-neg-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with And
[dynamic] Input file: 24-if-and-b.w...PASS (1/1 marks)
[mixed] Input file: 24-if-and-b.w...PASS (1/1 marks)
[static] Input file: 24-if-and-b.w...PASS (1/1 marks)
---
Test description: Bracketed If with Bexp
[dynamic] Input file: 25-if-b.w...PASS (1/1 marks)
[mixed] Input file: 25-if-b.w...PASS (1/1 marks)
[static] Input file: 25-if-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Le
[dynamic] Input file: 30-while-le-b.w...PASS (1/1 marks)
[mixed] Input file: 30-while-le-b.w...PASS (1/1 marks)
[static] Input file: 30-while-le-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Eq
[dynamic] Input file: 31-while-eq-b.w...PASS (1/1 marks)
[mixed] Input file: 31-while-eq-b.w...PASS (1/1 marks)
[static] Input file: 31-while-eq-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Neg
[dynamic] Input file: 32-while-neg-b.w...PASS (1/1 marks)
[mixed] Input file: 32-while-neg-b.w...PASS (1/1 marks)
[static] Input file: 32-while-neg-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with And
[dynamic] Input file: 33-while-and-b.w...PASS (1/1 marks)
[mixed] Input file: 33-while-and-b.w...PASS (1/1 marks)
[static] Input file: 33-while-and-b.w...PASS (1/1 marks)
---
Test description: Bracketed While with Bexp
[dynamic] Input file: 35-while-b.w...PASS (1/1 marks)
[mixed] Input file: 35-while-b.w...PASS (1/1 marks)
[static] Input file: 35-while-b.w...PASS (1/1 marks)
---
Test description: Factorial program – iterative version
[dynamic] Input file: 42-fact-iter.w...PASS (1/1 marks)
[mixed] Input file: 42-fact-iter.w...PASS (1/1 marks)
[static] Input file: 42-fact-iter.w...PASS (1/1 marks)
---
Test description: Factorial program – recursive version
[dynamic] Input file: 43-fact-rec.w...PASS (20/20 marks)
[mixed] Input file: 43-fact-rec.w...PASS (20/20 marks)
[static] Input file: 43-fact-rec.w...FAIL (0/20 marks)
"Declared variables:"
["x","y","z"]
"Initial state"
[5,0,0]
"Expected output:"
[1,120,0]
" Actual output:"
[5,1,0]
---
Test description: Simple mutual recursion program without brackets on final proc
[dynamic] Input file: 45-mutual2.w...FAIL (0/5 marks)
"Declared variables:"
["x"]
"Initial state"
[5]
"Expected output:"
[0]
" Actual output:"
[5]
[mixed] Input file: 45-mutual2.w...FAIL (0/5 marks)
"Declared variables:"
["x"]
"Initial state"
[5]
"Expected output:"
[0]
" Actual output:"
[5]
[static] Input file: 45-mutual2.w...FAIL (0/5 marks)
"Declared variables:"
["x"]
"Initial state"
[5]
"Expected output:"
[0]
" Actual output:"
[5]
---
Test description: Mutual recursion program based on J. Terry’s forum post
[dynamic] Input file: 46-mutual.w...PASS (5/5 marks)
[mixed] Input file: 46-mutual.w...FAIL (0/5 marks)
"Declared variables:"
["xinner","xouter","y"]
"Initial state"
[0,0,0]
"Expected output:"
[3,5,403]
" Actual output:"
[0,5,0]
[static] Input file: 46-mutual.w...FAIL (0/5 marks)
"Declared variables:"
["xinner","xouter","y"]
"Initial state"
[0,0,0]
"Expected output:"
[6,3,302]
" Actual output:"
[6,5,0]
---
Test description: Procedure scoping example program
[dynamic] Input file: 47-scope.w...PASS (25/25 marks)
[mixed] Input file: 47-scope.w...PASS (25/25 marks)
[static] Input file: 47-scope.w...PASS (25/25 marks)
---
Test description: Variable scoping example program
[dynamic] Input file: 48-var-scope.w...PASS (25/25 marks)
[mixed] Input file: 48-var-scope.w...PASS (25/25 marks)
[static] Input file: 48-var-scope.w...PASS (25/25 marks)
---
part 3 (dynamic) mark: 95
part 3 (mixed) mark: 90
part 3 (static) mark: 70
---
total part 3 mark: 86.0
Raw
proc.hs
module Proc where
import Prelude hiding (Num, and, lookup, map)
import Control.Applicative hiding (empty)
import Control.Arrow (second)
import Control.Monad
import Data.Functor.Identity (Identity)
import Data.Map.Lazy
import Data.Maybe
import Text.Megaparsec hiding (State, parse)
import qualified Text.Megaparsec.Lexer as L
import Text.Megaparsec.String
-- # Revisions
{-
- V1.2.1 01 May 2017
- Added State call fallback to prevent errors when using undeclared
variables known to a previous State. Further improvements -
especially reducing the memory footprint of the semantic functions -
could be made by replacing `Store` with `State` entirely except in
`Block`s. [:323]
- `Block`-private `Scope`s are now empty to reduce memory footprint,
as only the keys are needed to make a comparison. Further memory
footprint reductions could be made by changing the structure of
private `Store`s to ([Var], [Pname]) [:369, :377]
- Changed the scoping of `proc`s to be performed after all `var`s
and `proc`s have been declared to allow recursion and look-
forward. [:378 - :372]
- Mixed-scope state applicator now falls back on the current state if
the child scope cannot be found due to recursion (`Store` is only
set in the top-most declaration) [:368, :414]
- Removed some unused symbols
- TODO: Replace usage of `map` with `fmap` in next version [:398]
- TODO: Improve documentation
-}
--
-- # Grammar
{-
The grammar for Proc is as follows:
I ::= I Ib | Ia
Ia ::= a | b | ... | z | _
Ib ::= Ia | 0 | 1 | ... | 9
V ::= I
P ::= I
A ::= Aa + A | Aa - A | Aa
Aa ::= Ab * Aa | Ab
Ab ::= N | V | ( A )
B ::= Ba & B | Ba
Ba ::= Neg Ba | Bb
Bb ::= TRUE | FALSE | ( B ) | A <= A | A = A
Dv ::= var V := A ; Dv | E
Dp ::= proc P := Sa ; Dp | E
Sb ::= if B then S else S | while B do S | begin Dv Dp S end
Ss ::= skip | call P | x := A | ( S )
Sa ::= Sb | Ss
Sc ::= Sa ; S
S ::= Sb | Sc | Sa
-}
--
-- # Parser
-- ## Typedefs
type Num = Integer
type Var = String
type Pname = String
type DecV = [(Var, Aexp)]
type DecP = [(Pname, Stm)]
data Aexp = N Num | V Var | Mult Aexp Aexp | Add Aexp Aexp
| Sub Aexp Aexp
deriving (Show)
data Bexp = TRUE | FALSE | Neg Bexp | And Bexp Bexp
| Le Aexp Aexp | Eq Aexp Aexp
deriving (Show)
data Stm = Skip | Ass Var Aexp | Comp Stm Stm
| If Bexp Stm Stm | While Bexp Stm
| Block DecV DecP Stm | Call Pname
deriving (Show)
-- ## Lexer setup
spaceConsumer :: ParsecT Dec String Identity ()
spaceConsumer = L.space sp lc bc where
sp = void spaceChar
lc = L.skipLineComment "//"
bc = L.skipBlockComment "/*" "*/"
lexeme :: ParsecT Dec String Identity a
-> ParsecT Dec String Identity a
lexeme = L.lexeme spaceConsumer
symbol :: String -> ParsecT Dec String Identity String
symbol' :: String -> ParsecT Dec String Identity String
symbol = L.symbol spaceConsumer
symbol' = L.symbol' spaceConsumer
-- ## Lexeme Parsers
-- ### Parentheses
parens :: ParsecT Dec String Identity a
-> ParsecT Dec String Identity a
parens x = lexeme (between (symbol "(") (symbol ")") x)
<?> "parens"
-- ### Integers
num :: Parser Num
num = lexeme L.integer <?> "num"
-- ### Identity Names
-- Form of this function body inspired by
-- https://hackage.haskell.org/package/dotenv-0.3.0.3/src/src/Configuration/Dotenv/Parse.hs
ident :: ParsecT Dec String
Data.Functor.Identity.Identity String
ident = liftM2 (:) (letterChar <|> char '_')
(many $ try
(letterChar <|> char '_' <|> digitChar))
<?> "ident"
var :: Parser Var
var = lexeme ident <?> "var"
pname :: Parser Pname
pname = lexeme ident <?> "pname"
-- ## Declaration Block Parsers
-- ### Variable Declaration Blocks
decv :: Parser DecV
decv = many (try decv') <?> "decv" where
decv' = (,) <$> var' <*> a' <* symbol ";" <?> "decvi"
var' = symbol' "var" *> var <* symbol' ":="
<?> "decvv"
a' = aexp <?> "decva"
-- ### Procedure Declaration Blocks
decp :: Parser DecP
decp = many (try decp') <?> "decp" where
decp' = (,) <$> var' <*> s' <* symbol ";" <?> "decpi"
var' = symbol' "proc" *> pname <* symbol' "is"
<?> "decpv"
s' = stm' <?> "decps"
-- ## Expression Parsers
-- ### Arithmetic Expressions
aexp :: Parser Aexp
aexp = aexp0 <?> "aexp" where
-- Lowest precedence
aexp0 = try (Add <$> aexp1 <* symbol "+" <*> aexp0)
<|> try (Sub <$> aexp1 <* symbol "-" <*> aexp0)
<|> aexp1
aexp1 = try (Mult <$> aexp2 <* symbol "*" <*> aexp1)
<|> aexp2
-- Highest precedence & symbols
aexp2 = (N <$> num)
<|> (V <$> var)
<|> parens aexp
-- ### Boolean Expressions
bexp :: Parser Bexp
bexp = bexp0 <?> "bexp" where
-- Lowest precedence
bexp0 = try (And <$> bexp1 <* symbol "&" <*> bexp0)
<|> bexp1
bexp1 = try (Neg <$ symbol "!" <*> bexp1)
<|> bexp2
-- Highest precedence & symbols
bexp2 = (TRUE <$ symbol' "true")
<|> (FALSE <$ symbol' "false")
<|> parens bexp
<|> try (Le <$> aexp <* symbol "<=" <*> aexp)
<|> try (Eq <$> aexp <* symbol "=" <*> aexp)
-- ## Statement Parsers
-- ### Block Statements
stmb :: Parser Stm
stmb = (If <$ symbol' "if" <*> bexp
<* symbol' "then" <*> stm
<* symbol' "else" <*> stm
<?> "if")
<|> (While <$ symbol' "while" <*> bexp
<* symbol' "do" <*> stm
<?> "while")
<|> (Block <$ symbol' "begin" <*> decv
<*> decp <*> stm
<* symbol' "end"
<?> "block")
-- ### Inline Statements
stma :: Parser Stm
stma = (Skip <$ symbol' "skip"
<?> "skip")
<|> (Call <$ symbol' "call" <*> pname
<?> "call")
<|> (try (Ass <$> var <* symbol ":=" <*> aexp)
<?> "ass")
<|> parens stm <?> "parens'"
-- ### Single Statements
stm' :: Parser Stm
stm' = stmb <|> stma
-- ### Composite Statements
comp :: Parser Stm
comp = try (Comp <$> stm' <* symbol ";"
<*> stm)
<?> "comp"
-- ### General Statements
stm :: Parser Stm
stm = stmb <|> comp <|> stma
-- ### Outermost Statement Parser
prog :: Parser Stm
prog = spaceConsumer *> stm
-- ## Parser Applicators
parse :: String -> Stm
parse = fromJust . parseMaybe prog
parseDebug :: String -> IO ()
parseDebug x = case runParser prog "" x of
Left err -> putStr (parseErrorPretty err)
Right f -> print f
--
-- # Semantic Functions
-- ## Typedefs
{-# ANN module "HLint: ignore Use camelCase" #-}
type T = Bool
type Z = Integer
type State = Var -> Z
data Scope = Scope (Map Pname (Stm, Maybe Scope))
(Map Var (Maybe Z)) State
-- ## Expression Evaluation
-- ### Arithmetic Expressions
aexpEval :: Aexp -> Scope -> Maybe Z
aexpEval = aee where
aee (N a) _ = Just a
aee (V a ) s = svLookup s a
aee (Mult a b) s = f' (*) a b s
aee (Add a b) s = f' (+) a b s
aee (Sub a b) s = f' (-) a b s
f' g a b s = pure g <*> aee a s <*> aee b s
-- ### Boolean Expressions
bexpEval :: Bexp -> Scope -> T
bexpEval = bee where
bee TRUE _ = True
bee FALSE _ = False
bee (And a b) s = bee a s && bee b s
bee (Neg a ) s = not $ bee a s
bee (Le a b) s = justAee a s <= justAee b s
bee (Eq a b) s = justAee a s == justAee b s
justAee a = fromJust . aexpEval a
-- ## Scope Manipulation
-- ### Scope Lookup
svLookup :: Scope -> Var -> Maybe Z
spLookup :: Scope -> Pname -> (Stm, Maybe Scope)
svLookup (Scope _ vs s) v = fromMaybe (Just $ s v) $ lookup v vs
spLookup (Scope ps _ _) = (!) ps
-- ### Insert Procedures
-- ### Insert Variables
-- ## Generic State Applicator
s_generic :: (Stm -> Scope -> Scope)
-> Stm -> State -> State
s_generic a f s v = fromJust $ svLookup (g' a f s v) v where
g' :: (Stm -> Scope -> Scope)
-> Stm -> State -> Var -> Scope
g' a' f' s' v' = a' f' (Scope empty
(singleton v' . Just . s' $ v') s')
-- ## Default Scope Applicator
siDefault :: (Stm -> Scope -> Scope) -> Stm -> Scope ->
Scope
siDefault _ Skip _ = Scope empty empty $ const 0
siDefault _ (Ass v a)
(Scope ps vs s) = Scope ps
(insert v (aexpEval a (Scope ps vs s)) vs) s
siDefault i (Comp a b) s = i b (i a s)
siDefault i (If c f g) s = i (if bexpEval c s then f else g) s
siDefault i (While c f) s = if bexpEval c s
then i (While c f) (i f s)
else s
siDefault i (Block v p f)
s@(Scope ps vs sc) =
let addPs :: DecP -> (Scope, Scope) -> (Scope, Scope)
addPs [] ss = ss
addPs ((q, qf) : qs)
(Scope po vo so,
Scope pp vp sp) = addPs qs
(Scope (insert q (qf, Nothing) po) vo so,
Scope (insert q (Skip, Nothing) pp) vp sp)
addVs :: DecV -> (Scope, Scope) -> (Scope, Scope)
addVs [] ss = ss
addVs ((u, ua) : us)
(so@(Scope po vo to),
Scope pp vp tp) = addVs us (Scope po
(insert u (aexpEval ua so) vo) to,
Scope pp
(insert u Nothing vp) tp)
rescopePs :: (Scope, Scope) -> (Scope, Scope)
rescopePs
(so@(Scope po vo to),
sp) = (Scope (setScope so po) vo to, sp)
setScope ss = map (second (Just . fromMaybe ss))
sa :: (Scope, Scope)
sa = rescopePs .
addPs p $ addVs v
(s, Scope empty empty $ const 0)
(Scope pps pvs _) = snd sa
(Scope fp fv _) = i f $ fst sa
in Scope (difference fp pps `union` ps)
(difference fv pvs `union` vs) sc
siDefault _ _ _ = undefined
-- ## Dynamic-scope State Applicator
s_dynamic :: Stm -> State -> State
s_dynamic = s_generic d' where
d' :: Stm -> Scope -> Scope
d' (Call p) s = let (p', _) = spLookup s p
in d' p' s
d' f s = siDefault d' f s
-- ## Mixed-scope State Applicator
s_mixed :: Stm -> State -> State
s_mixed = s_generic m' where
m' :: Stm -> Scope -> Scope
m' (Call p)
s@(Scope _ vs sc) = let (p', s') = spLookup s p
(Scope ps' _ _) = fromMaybe s s'
in m' p' (Scope ps' vs sc)
m' f s = siDefault m' f s
-- ## Static-scope State Applicator
s_static :: Stm -> State -> State
s_static = s_generic s' where
s' (Call _) s = s
s' f s = siDefault s' f s
--
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment