Partially test under Hugs, as well as under ghc.
--HG--
rename : src/hev.hs => src/Hev.hs
Cat's Eye Technologies
11 years ago
| 0 | -- | |
| 1 | -- hev.hs | |
| 2 | -- Reference Interpreter for the Hev Programming Language | |
| 3 | -- Begun November 2005, fleshed out October 2006, polished off June 2007 | |
| 4 | -- Chris Pressey, Cat's Eye Technologies | |
| 5 | -- | |
| 6 | ||
| 7 | -- | |
| 8 | -- Copyright (c)2005-2012 Chris Pressey, Cat's Eye Technologies. | |
| 9 | -- All rights reserved. | |
| 10 | -- | |
| 11 | -- Redistribution and use in source and binary forms, with or without | |
| 12 | -- modification, are permitted provided that the following conditions | |
| 13 | -- are met: | |
| 14 | -- | |
| 15 | -- 1. Redistributions of source code must retain the above copyright | |
| 16 | -- notices, this list of conditions and the following disclaimer. | |
| 17 | -- 2. Redistributions in binary form must reproduce the above copyright | |
| 18 | -- notices, this list of conditions, and the following disclaimer in | |
| 19 | -- the documentation and/or other materials provided with the | |
| 20 | -- distribution. | |
| 21 | -- 3. Neither the names of the copyright holders nor the names of their | |
| 22 | -- contributors may be used to endorse or promote products derived | |
| 23 | -- from this software without specific prior written permission. | |
| 24 | -- | |
| 25 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
| 26 | -- ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
| 27 | -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
| 28 | -- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
| 29 | -- COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
| 30 | -- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
| 31 | -- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
| 32 | -- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
| 33 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
| 34 | -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
| 35 | -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
| 36 | -- POSSIBILITY OF SUCH DAMAGE. | |
| 37 | ||
| 38 | module Hev where | |
| 39 | ||
| 40 | ----------------------------------------------------------------------- | |
| 41 | -- ========================== Data types =========================== -- | |
| 42 | ----------------------------------------------------------------------- | |
| 43 | ||
| 44 | import Data.Char | |
| 45 | ||
| 46 | -- | |
| 47 | -- A data type giving the structure of the trees that Hev programs | |
| 48 | -- describe. They contain no values, but the (sub)trees that will | |
| 49 | -- be used as pattern-matching rules can contain variables. | |
| 50 | -- | |
| 51 | ||
| 52 | data Tree = TreeBranch Tree Tree | |
| 53 | | TreeLeaf | |
| 54 | | TreeVar String | |
| 55 | deriving (Show, Read, Eq) | |
| 56 | ||
| 57 | -- | |
| 58 | -- A data type describing unifiers. Really, a unifier is just a | |
| 59 | -- list of name-value associations, like an environment. | |
| 60 | -- | |
| 61 | ||
| 62 | data Unifier = UnifierBinding String Tree Unifier | |
| 63 | | UnifierNil | |
| 64 | | UnificationFailure | |
| 65 | deriving (Show, Read, Eq) | |
| 66 | ||
| 67 | -- | |
| 68 | -- A data type for possibly infinite numbers, so that various values | |
| 69 | -- in this evaluator (specifically, the "roof" parameter to buildTree) | |
| 70 | -- aren't artifically bounded. | |
| 71 | -- | |
| 72 | -- I could probably do something fancy by overriding '>' in the | |
| 73 | -- Ord type class here, but for now at least, I won't. | |
| 74 | -- | |
| 75 | ||
| 76 | data PossiblyInfinite a = Finite a | |
| 77 | | Infinity | |
| 78 | deriving (Show, Read, Eq) | |
| 79 | ||
| 80 | isGreater i (Finite j) = i > j | |
| 81 | isGreater i Infinity = False | |
| 82 | ||
| 83 | ||
| 84 | ----------------------------------------------------------------------- | |
| 85 | -- ============================= Parser ============================ -- | |
| 86 | ----------------------------------------------------------------------- | |
| 87 | ||
| 88 | -- | |
| 89 | -- Determine the integer value of a decimal digit character. | |
| 90 | -- | |
| 91 | ||
| 92 | digitVal '0' = 0 | |
| 93 | digitVal '1' = 1 | |
| 94 | digitVal '2' = 2 | |
| 95 | digitVal '3' = 3 | |
| 96 | digitVal '4' = 4 | |
| 97 | digitVal '5' = 5 | |
| 98 | digitVal '6' = 6 | |
| 99 | digitVal '7' = 7 | |
| 100 | digitVal '8' = 8 | |
| 101 | digitVal '9' = 9 | |
| 102 | ||
| 103 | -- | |
| 104 | -- Accumulate the value of a digit onto the end of a integer | |
| 105 | -- and return the result. | |
| 106 | -- | |
| 107 | ||
| 108 | accumulate char num = | |
| 109 | (num * 10) + digitVal char | |
| 110 | ||
| 111 | -- | |
| 112 | -- Scan an integer in decimal notation at the start of | |
| 113 | -- a string; return a pair consisting of the integer | |
| 114 | -- and the rest of the string. | |
| 115 | -- | |
| 116 | ||
| 117 | consumeOperator [] num = (num, []) | |
| 118 | consumeOperator string@(char:chars) num | |
| 119 | | isSpace char = | |
| 120 | consumeOperator chars num | |
| 121 | | isDigit char = | |
| 122 | consumeOperator chars (accumulate char num) | |
| 123 | | otherwise = | |
| 124 | (num, string) | |
| 125 | ||
| 126 | -- | |
| 127 | -- Determine if a given character is suitable for use in an atom | |
| 128 | -- | |
| 129 | ||
| 130 | isAtomSymbol ',' = True | |
| 131 | isAtomSymbol '+' = True | |
| 132 | isAtomSymbol '-' = True | |
| 133 | isAtomSymbol '*' = True | |
| 134 | isAtomSymbol '/' = True | |
| 135 | isAtomSymbol _ = False | |
| 136 | ||
| 137 | -- | |
| 138 | -- Convert the textual representation of an atom to | |
| 139 | -- its internal representation. | |
| 140 | -- | |
| 141 | ||
| 142 | stringToTree [] = TreeLeaf | |
| 143 | stringToTree "," = TreeLeaf | |
| 144 | stringToTree string = TreeVar string | |
| 145 | ||
| 146 | -- | |
| 147 | -- Scan a symbol from the start of a string; return a pair | |
| 148 | -- consisting of the corresponding tree representation of | |
| 149 | -- the atom, and the rest of the string. | |
| 150 | -- | |
| 151 | ||
| 152 | consumeAtom [] acc = | |
| 153 | (stringToTree acc, []) | |
| 154 | consumeAtom string@(char:chars) acc | |
| 155 | | isSpace char = | |
| 156 | consumeAtom chars acc | |
| 157 | | isAtomSymbol char = | |
| 158 | consumeAtom chars (acc ++ [char]) | |
| 159 | | otherwise = | |
| 160 | (stringToTree acc, string) | |
| 161 | ||
| 162 | -- | |
| 163 | -- Convert the textual representation of a Hev program to | |
| 164 | -- an internal representation (a list of operator-atom pairs.) | |
| 165 | -- | |
| 166 | ||
| 167 | stringToPairs "" = [] | |
| 168 | stringToPairs string = | |
| 169 | let | |
| 170 | (op, string2) = consumeOperator string 0 | |
| 171 | (atom, string3) = consumeAtom string2 [] | |
| 172 | in | |
| 173 | ((op, atom) : (stringToPairs string3)) | |
| 174 | ||
| 175 | -- | |
| 176 | -- Be not deceived by the apparent simplicity of the following | |
| 177 | -- function! It took me the better part of a day to get it right. | |
| 178 | -- | |
| 179 | -- This function builds a tree corresponding to each of the | |
| 180 | -- operators in the list of (operator, atom) pairs, up until | |
| 181 | -- (and not including) the first operator in the list which | |
| 182 | -- exceeds a given maximum value (which we call the "roof".) | |
| 183 | -- Once this roof-exceeding value is found (or there are no | |
| 184 | -- more elements in the list,) this tree is returned (along | |
| 185 | -- with the unused portion of the list.) | |
| 186 | -- | |
| 187 | -- The root of the tree so built corresponds to the largest | |
| 188 | -- operator found in the list. The list is thus conceptually | |
| 189 | -- divided into a left sublist and a right sublist. | |
| 190 | -- Recursively, the left subtree of the root is associated | |
| 191 | -- with the largest operator in the left sublist, and the | |
| 192 | -- right subtree with the largest operator in the right sublist. | |
| 193 | -- | |
| 194 | -- And in fact, the straightforward way to implement this | |
| 195 | -- function would be to do just that: search for the largest | |
| 196 | -- element of the list, split the list into two sublists, and | |
| 197 | -- process each of those sublists recursively. However, there | |
| 198 | -- is a certain elegance (and presumably efficiency, although | |
| 199 | -- that's not the motivation here) that is derived from doing | |
| 200 | -- only one pass, left to right, through the list, and that's | |
| 201 | -- the approach I've chosen to take. Thus we have the | |
| 202 | -- following implementation. | |
| 203 | -- | |
| 204 | -- The function basically loops around, consuming the list from | |
| 205 | -- left to right while tracking some state: | |
| 206 | -- | |
| 207 | -- roof - as noted, the upper limit to the value of operator | |
| 208 | -- that we accept. When we see it, we return the | |
| 209 | -- built tree and the rest of the list to our caller. | |
| 210 | -- bigOp - the biggest operator we have seen in the list so | |
| 211 | -- far, locally speaking. That is, it will always be | |
| 212 | -- smaller than the roof value. It is used to decide | |
| 213 | -- when to start building a subtree. | |
| 214 | -- bigTree - the tree value associated with bigOp; acts more or | |
| 215 | -- less like an accumulator. | |
| 216 | -- prevAtom - needed to get the variables into the leaves of the | |
| 217 | -- tree where they logically belong. (The left | |
| 218 | -- subtree of the bottom branch actually needs the | |
| 219 | -- variable that is paired with the previous operator | |
| 220 | -- in the list.) | |
| 221 | -- | |
| 222 | -- During the loop, behaviour is split into three cases: | |
| 223 | -- | |
| 224 | -- Case 1: the operator exceeds the roof; return. | |
| 225 | -- Case 2: the operator is bigger than the biggest operator | |
| 226 | -- seen so far. Use it as the biggest operator, construct | |
| 227 | -- a tree node for it for use as the biggest tree, and | |
| 228 | -- loop around to tackle the next operator in the list. | |
| 229 | -- Case 3: the operator is smaller than the biggest operator | |
| 230 | -- seen so far. Create a subtree by recursively calling | |
| 231 | -- buildTreeLoop. For this call, the roof value is given | |
| 232 | -- by the biggest operator, and the biggest operator is | |
| 233 | -- initially set back to zero. The returned subtree is | |
| 234 | -- spliced into the biggest tree, as the right child. | |
| 235 | -- The loop then continues. The altered biggest tree, | |
| 236 | -- and the amount of the list consumed by the creation of | |
| 237 | -- the subtree are taken into account for the next loop | |
| 238 | -- iteration, but the roof and biggest operator do not | |
| 239 | -- change. | |
| 240 | -- | |
| 241 | ||
| 242 | buildTree [] roof bigOp bigTree prevAtom = | |
| 243 | (bigTree, []) | |
| 244 | buildTree pairs@((op, atom):restOfPairs) roof bigOp bigTree prevAtom | |
| 245 | | isGreater op roof = | |
| 246 | (bigTree, pairs) | |
| 247 | | op > bigOp = | |
| 248 | let | |
| 249 | newBigTree = TreeBranch bigTree atom | |
| 250 | in | |
| 251 | buildTree restOfPairs roof op newBigTree atom | |
| 252 | | op < bigOp = | |
| 253 | let | |
| 254 | (subTree, newPairs) = buildTree pairs (Finite bigOp) 0 prevAtom atom | |
| 255 | (TreeBranch bigTreeLeft bigTreeRight) = bigTree | |
| 256 | newBigTree = (TreeBranch bigTreeLeft subTree) | |
| 257 | in | |
| 258 | buildTree newPairs roof bigOp newBigTree atom | |
| 259 | ||
| 260 | -- | |
| 261 | -- Parse a Hev program into a valueless tree. | |
| 262 | -- | |
| 263 | ||
| 264 | parse string = | |
| 265 | fst (buildTree (stringToPairs string) Infinity 0 TreeLeaf TreeLeaf) | |
| 266 | ||
| 267 | ||
| 268 | ----------------------------------------------------------------------- | |
| 269 | -- ======================= Static Checker ========================== -- | |
| 270 | ----------------------------------------------------------------------- | |
| 271 | ||
| 272 | -- | |
| 273 | -- Return a list of all variables that occur in a given tree. | |
| 274 | -- | |
| 275 | ||
| 276 | getVariables TreeLeaf = [] | |
| 277 | getVariables (TreeVar var) = [var] | |
| 278 | getVariables (TreeBranch left right) = | |
| 279 | (getVariables left) ++ (getVariables right) | |
| 280 | ||
| 281 | -- | |
| 282 | -- Determine whether every element of the first list is also an element | |
| 283 | -- of the second list. | |
| 284 | -- | |
| 285 | ||
| 286 | isSubset [] _ = True | |
| 287 | isSubset (first:rest) list = | |
| 288 | (elem first list) && (isSubset rest list) | |
| 289 | where | |
| 290 | elem x [] = False | |
| 291 | elem x (first:rest) | |
| 292 | | x == first = True | |
| 293 | | otherwise = elem x rest | |
| 294 | ||
| 295 | -- | |
| 296 | -- Determine whether a tree is "ground", i.e. contains no variables. | |
| 297 | -- | |
| 298 | ||
| 299 | isGround tree = getVariables tree == [] | |
| 300 | ||
| 301 | -- | |
| 302 | -- Determine whether a set of rules is complete (each rule is complete, | |
| 303 | -- and the tree by which the ruleset itself is represented doesn't have | |
| 304 | -- any variables.) | |
| 305 | -- | |
| 306 | ||
| 307 | rulesComplete TreeLeaf = True | |
| 308 | rulesComplete (TreeVar _) = False | |
| 309 | rulesComplete (TreeBranch left right) = | |
| 310 | ruleComplete right && rulesComplete left | |
| 311 | ||
| 312 | -- | |
| 313 | -- Determine whether a rule is complete (it has has both a head and a | |
| 314 | -- body, and there are no variables in the body that aren't in the head.) | |
| 315 | -- | |
| 316 | ||
| 317 | ruleComplete TreeLeaf = False | |
| 318 | ruleComplete (TreeVar _) = False | |
| 319 | ruleComplete (TreeBranch head body) = | |
| 320 | isSubset (getVariables body) (getVariables head) | |
| 321 | ||
| 322 | -- | |
| 323 | -- Parse and check a Hev program. Returns an illegal tree (which will | |
| 324 | -- cause a Haskell runtime pattern-match error later on) if there are | |
| 325 | -- static errors detected in the Hev program. | |
| 326 | -- | |
| 327 | ||
| 328 | compile string | |
| 329 | | not (isGround stateTree) = | |
| 330 | TreeLeaf | |
| 331 | | not (rulesComplete ruleTree) = | |
| 332 | TreeLeaf | |
| 333 | | otherwise = | |
| 334 | tree | |
| 335 | where | |
| 336 | tree@(TreeBranch ruleTree stateTree) = parse string | |
| 337 | ||
| 338 | ||
| 339 | ----------------------------------------------------------------------- | |
| 340 | -- ======================= Tree rewriting ========================== -- | |
| 341 | ----------------------------------------------------------------------- | |
| 342 | ||
| 343 | -- | |
| 344 | -- Given a variable and a unifier, get the value given in | |
| 345 | -- the unifier for than variable, or Nothing if it is not found. | |
| 346 | -- | |
| 347 | ||
| 348 | getBinding _ UnificationFailure = | |
| 349 | Nothing | |
| 350 | getBinding _ UnifierNil = | |
| 351 | Nothing | |
| 352 | getBinding targetVar (UnifierBinding sourceVar tree unifier) | |
| 353 | | targetVar == sourceVar = | |
| 354 | Just tree | |
| 355 | | otherwise = | |
| 356 | getBinding targetVar unifier | |
| 357 | ||
| 358 | -- | |
| 359 | -- Match a "pattern" tree (the first argument) to a "state" tree and | |
| 360 | -- return the most general unifier, or nothing. | |
| 361 | -- | |
| 362 | ||
| 363 | match _ _ UnificationFailure = UnificationFailure | |
| 364 | match TreeLeaf TreeLeaf unifier = unifier | |
| 365 | match (TreeBranch left1 right1) (TreeBranch left2 right2) unifier = | |
| 366 | let | |
| 367 | unifier2 = match left1 left2 unifier | |
| 368 | unifier3 = match right1 right2 unifier2 | |
| 369 | in | |
| 370 | unifier3 | |
| 371 | match (TreeVar var) subTree unifier | |
| 372 | | binding == Nothing = | |
| 373 | UnifierBinding var subTree unifier | |
| 374 | | binding /= Just subTree = | |
| 375 | UnificationFailure | |
| 376 | | otherwise = | |
| 377 | unifier | |
| 378 | where | |
| 379 | binding = getBinding var unifier | |
| 380 | match _ _ _ = UnificationFailure | |
| 381 | ||
| 382 | -- | |
| 383 | -- Given a tree containing variables and a unifier, construct | |
| 384 | -- a "ground" tree (one with no variables) by replacing each | |
| 385 | -- variable with the value associated with it in the unifier. | |
| 386 | -- | |
| 387 | ||
| 388 | expand TreeLeaf unifier = TreeLeaf | |
| 389 | expand (TreeBranch left right) unifier = | |
| 390 | TreeBranch (expand left unifier) (expand right unifier) | |
| 391 | expand (TreeVar var) unifier = | |
| 392 | let | |
| 393 | (Just subTree) = getBinding var unifier | |
| 394 | in | |
| 395 | subTree | |
| 396 | ||
| 397 | -- | |
| 398 | -- Try to match the given pattern (the head of a rule) in | |
| 399 | -- the given tree. If there are multiple places where | |
| 400 | -- the pattern might match the tree, only the topmost leftmost | |
| 401 | -- one is chosen. Then return a new tree with the matched | |
| 402 | -- portion replaced by the body (appropriately expanded | |
| 403 | -- with any matched variables) if a match succeeded, or | |
| 404 | -- the original tree if no match succeeded. In either case, | |
| 405 | -- a boolean indicating whether the match succeeded is | |
| 406 | -- returned as well. | |
| 407 | -- | |
| 408 | ||
| 409 | rewrite tree@(TreeBranch left right) head body | |
| 410 | | unifier /= UnificationFailure = | |
| 411 | (True, expand body unifier) | |
| 412 | | successLeft = | |
| 413 | (True, TreeBranch newSubTreeLeft right) | |
| 414 | | successRight = | |
| 415 | (True, TreeBranch left newSubTreeRight) | |
| 416 | | otherwise = | |
| 417 | (False, tree) | |
| 418 | where | |
| 419 | unifier = match head tree UnifierNil | |
| 420 | (successLeft, newSubTreeLeft) = (rewrite left head body) | |
| 421 | (successRight, newSubTreeRight) = (rewrite right head body) | |
| 422 | ||
| 423 | rewrite tree head body | |
| 424 | | unifier /= UnificationFailure = | |
| 425 | (True, expand body unifier) | |
| 426 | | otherwise = | |
| 427 | (False, tree) | |
| 428 | where | |
| 429 | unifier = match head tree UnifierNil | |
| 430 | ||
| 431 | ||
| 432 | ----------------------------------------------------------------------- | |
| 433 | -- =========================== Execution =========================== -- | |
| 434 | ----------------------------------------------------------------------- | |
| 435 | ||
| 436 | -- | |
| 437 | -- A program is represented by | |
| 438 | -- | |
| 439 | -- _______root_______ | |
| 440 | -- / \ | |
| 441 | -- X ...state... | |
| 442 | -- / \ | |
| 443 | -- X rule | |
| 444 | -- / \ | |
| 445 | -- ... rule | |
| 446 | -- | |
| 447 | ||
| 448 | -- | |
| 449 | -- Each rule is represented by | |
| 450 | -- | |
| 451 | -- __rule__ | |
| 452 | -- / \ | |
| 453 | -- head body | |
| 454 | -- | |
| 455 | -- where the head is the pattern which will be matched against the | |
| 456 | -- state, and the body is the replacement which will be substituted. | |
| 457 | -- | |
| 458 | ||
| 459 | -- | |
| 460 | -- Here's how the interpreter works: | |
| 461 | -- | |
| 462 | -- Assemble a working list of rules (initially all rules.) | |
| 463 | -- | |
| 464 | -- Pick the first available rule from the working list of rules. | |
| 465 | -- | |
| 466 | -- Match the head of the rule against the state tree. | |
| 467 | -- | |
| 468 | -- If there was a match, replace the matched portion with an | |
| 469 | -- appropriate instantiation of the body of the rule, and repeat | |
| 470 | -- from the very beginning. | |
| 471 | -- | |
| 472 | -- If there was no match, remove this pattern from the working list of | |
| 473 | -- patterns and try again with the shorter working list. | |
| 474 | -- | |
| 475 | -- If this was the last working pattern, end. | |
| 476 | -- | |
| 477 | ||
| 478 | run (TreeBranch patternTree stateTree) = | |
| 479 | loop patternTree patternTree stateTree | |
| 480 | where | |
| 481 | loop TreeLeaf all state = state | |
| 482 | loop (TreeBranch rest pat@(TreeBranch head body)) all state | |
| 483 | | matched = | |
| 484 | loop all all state' | |
| 485 | | otherwise = | |
| 486 | loop rest all state | |
| 487 | where | |
| 488 | (matched, state') = rewrite state head body |
| 0 | module Main where | |
| 1 | ||
| 2 | import System.Environment | |
| 3 | import Hev | |
| 4 | ||
| 5 | main = do | |
| 6 | [command, fileName] <- getArgs | |
| 7 | c <- readFile fileName | |
| 8 | case command of | |
| 9 | "parse" -> | |
| 10 | putStr $ show $ parse c | |
| 11 | "compile" -> | |
| 12 | putStr $ show $ compile c | |
| 13 | "getbinding" -> | |
| 14 | putStr $ show $ getBinding c (UnifierBinding "-" TreeLeaf (UnifierBinding "+" (TreeBranch TreeLeaf TreeLeaf) UnifierNil)) | |
| 15 | -- "match" -> | |
| 16 | -- putStr $ show $ match $ parse c | |
| 17 | -- "rewrite" -> | |
| 18 | -- putStr $ show $ rewrite $ parse c | |
| 19 | "run" -> | |
| 20 | putStr $ show $ run $ compile c |
| 0 | -- | |
| 1 | -- hev.hs | |
| 2 | -- Reference Interpreter for the Hev Programming Language | |
| 3 | -- Begun November 2005, fleshed out October 2006, polished off June 2007 | |
| 4 | -- Chris Pressey, Cat's Eye Technologies | |
| 5 | -- | |
| 6 | ||
| 7 | -- | |
| 8 | -- Copyright (c)2005-2012 Chris Pressey, Cat's Eye Technologies. | |
| 9 | -- All rights reserved. | |
| 10 | -- | |
| 11 | -- Redistribution and use in source and binary forms, with or without | |
| 12 | -- modification, are permitted provided that the following conditions | |
| 13 | -- are met: | |
| 14 | -- | |
| 15 | -- 1. Redistributions of source code must retain the above copyright | |
| 16 | -- notices, this list of conditions and the following disclaimer. | |
| 17 | -- 2. Redistributions in binary form must reproduce the above copyright | |
| 18 | -- notices, this list of conditions, and the following disclaimer in | |
| 19 | -- the documentation and/or other materials provided with the | |
| 20 | -- distribution. | |
| 21 | -- 3. Neither the names of the copyright holders nor the names of their | |
| 22 | -- contributors may be used to endorse or promote products derived | |
| 23 | -- from this software without specific prior written permission. | |
| 24 | -- | |
| 25 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
| 26 | -- ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT | |
| 27 | -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS | |
| 28 | -- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE | |
| 29 | -- COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, | |
| 30 | -- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, | |
| 31 | -- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; | |
| 32 | -- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | |
| 33 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
| 34 | -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN | |
| 35 | -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE | |
| 36 | -- POSSIBILITY OF SUCH DAMAGE. | |
| 37 | ||
| 38 | module Hev where | |
| 39 | ||
| 40 | ----------------------------------------------------------------------- | |
| 41 | -- ========================== Data types =========================== -- | |
| 42 | ----------------------------------------------------------------------- | |
| 43 | ||
| 44 | import Data.Char | |
| 45 | ||
| 46 | -- | |
| 47 | -- A data type giving the structure of the trees that Hev programs | |
| 48 | -- describe. They contain no values, but the (sub)trees that will | |
| 49 | -- be used as pattern-matching rules can contain variables. | |
| 50 | -- | |
| 51 | ||
| 52 | data Tree = TreeBranch Tree Tree | |
| 53 | | TreeLeaf | |
| 54 | | TreeVar String | |
| 55 | deriving (Show, Read, Eq) | |
| 56 | ||
| 57 | -- | |
| 58 | -- A data type describing unifiers. Really, a unifier is just a | |
| 59 | -- list of name-value associations, like an environment. | |
| 60 | -- | |
| 61 | ||
| 62 | data Unifier = UnifierBinding String Tree Unifier | |
| 63 | | UnifierNil | |
| 64 | | UnificationFailure | |
| 65 | deriving (Show, Read, Eq) | |
| 66 | ||
| 67 | -- | |
| 68 | -- A data type for possibly infinite numbers, so that various values | |
| 69 | -- in this evaluator (specifically, the "roof" parameter to buildTree) | |
| 70 | -- aren't artifically bounded. | |
| 71 | -- | |
| 72 | -- I could probably do something fancy by overriding '>' in the | |
| 73 | -- Ord type class here, but for now at least, I won't. | |
| 74 | -- | |
| 75 | ||
| 76 | data PossiblyInfinite a = Finite a | |
| 77 | | Infinity | |
| 78 | deriving (Show, Read, Eq) | |
| 79 | ||
| 80 | isGreater i (Finite j) = i > j | |
| 81 | isGreater i Infinity = False | |
| 82 | ||
| 83 | ||
| 84 | ----------------------------------------------------------------------- | |
| 85 | -- ============================= Parser ============================ -- | |
| 86 | ----------------------------------------------------------------------- | |
| 87 | ||
| 88 | -- | |
| 89 | -- Determine the integer value of a decimal digit character. | |
| 90 | -- | |
| 91 | ||
| 92 | digitVal '0' = 0 | |
| 93 | digitVal '1' = 1 | |
| 94 | digitVal '2' = 2 | |
| 95 | digitVal '3' = 3 | |
| 96 | digitVal '4' = 4 | |
| 97 | digitVal '5' = 5 | |
| 98 | digitVal '6' = 6 | |
| 99 | digitVal '7' = 7 | |
| 100 | digitVal '8' = 8 | |
| 101 | digitVal '9' = 9 | |
| 102 | ||
| 103 | -- | |
| 104 | -- Accumulate the value of a digit onto the end of a integer | |
| 105 | -- and return the result. | |
| 106 | -- | |
| 107 | ||
| 108 | accumulate char num = | |
| 109 | (num * 10) + digitVal char | |
| 110 | ||
| 111 | -- | |
| 112 | -- Scan an integer in decimal notation at the start of | |
| 113 | -- a string; return a pair consisting of the integer | |
| 114 | -- and the rest of the string. | |
| 115 | -- | |
| 116 | ||
| 117 | consumeOperator [] num = (num, []) | |
| 118 | consumeOperator string@(char:chars) num | |
| 119 | | isSpace char = | |
| 120 | consumeOperator chars num | |
| 121 | | isDigit char = | |
| 122 | consumeOperator chars (accumulate char num) | |
| 123 | | otherwise = | |
| 124 | (num, string) | |
| 125 | ||
| 126 | -- | |
| 127 | -- Determine if a given character is suitable for use in an atom | |
| 128 | -- | |
| 129 | ||
| 130 | isAtomSymbol ',' = True | |
| 131 | isAtomSymbol '+' = True | |
| 132 | isAtomSymbol '-' = True | |
| 133 | isAtomSymbol '*' = True | |
| 134 | isAtomSymbol '/' = True | |
| 135 | isAtomSymbol _ = False | |
| 136 | ||
| 137 | -- | |
| 138 | -- Convert the textual representation of an atom to | |
| 139 | -- its internal representation. | |
| 140 | -- | |
| 141 | ||
| 142 | stringToTree [] = TreeLeaf | |
| 143 | stringToTree "," = TreeLeaf | |
| 144 | stringToTree string = TreeVar string | |
| 145 | ||
| 146 | -- | |
| 147 | -- Scan a symbol from the start of a string; return a pair | |
| 148 | -- consisting of the corresponding tree representation of | |
| 149 | -- the atom, and the rest of the string. | |
| 150 | -- | |
| 151 | ||
| 152 | consumeAtom [] acc = | |
| 153 | (stringToTree acc, []) | |
| 154 | consumeAtom string@(char:chars) acc | |
| 155 | | isSpace char = | |
| 156 | consumeAtom chars acc | |
| 157 | | isAtomSymbol char = | |
| 158 | consumeAtom chars (acc ++ [char]) | |
| 159 | | otherwise = | |
| 160 | (stringToTree acc, string) | |
| 161 | ||
| 162 | -- | |
| 163 | -- Convert the textual representation of a Hev program to | |
| 164 | -- an internal representation (a list of operator-atom pairs.) | |
| 165 | -- | |
| 166 | ||
| 167 | stringToPairs "" = [] | |
| 168 | stringToPairs string = | |
| 169 | let | |
| 170 | (op, string2) = consumeOperator string 0 | |
| 171 | (atom, string3) = consumeAtom string2 [] | |
| 172 | in | |
| 173 | ((op, atom) : (stringToPairs string3)) | |
| 174 | ||
| 175 | -- | |
| 176 | -- Be not deceived by the apparent simplicity of the following | |
| 177 | -- function! It took me the better part of a day to get it right. | |
| 178 | -- | |
| 179 | -- This function builds a tree corresponding to each of the | |
| 180 | -- operators in the list of (operator, atom) pairs, up until | |
| 181 | -- (and not including) the first operator in the list which | |
| 182 | -- exceeds a given maximum value (which we call the "roof".) | |
| 183 | -- Once this roof-exceeding value is found (or there are no | |
| 184 | -- more elements in the list,) this tree is returned (along | |
| 185 | -- with the unused portion of the list.) | |
| 186 | -- | |
| 187 | -- The root of the tree so built corresponds to the largest | |
| 188 | -- operator found in the list. The list is thus conceptually | |
| 189 | -- divided into a left sublist and a right sublist. | |
| 190 | -- Recursively, the left subtree of the root is associated | |
| 191 | -- with the largest operator in the left sublist, and the | |
| 192 | -- right subtree with the largest operator in the right sublist. | |
| 193 | -- | |
| 194 | -- And in fact, the straightforward way to implement this | |
| 195 | -- function would be to do just that: search for the largest | |
| 196 | -- element of the list, split the list into two sublists, and | |
| 197 | -- process each of those sublists recursively. However, there | |
| 198 | -- is a certain elegance (and presumably efficiency, although | |
| 199 | -- that's not the motivation here) that is derived from doing | |
| 200 | -- only one pass, left to right, through the list, and that's | |
| 201 | -- the approach I've chosen to take. Thus we have the | |
| 202 | -- following implementation. | |
| 203 | -- | |
| 204 | -- The function basically loops around, consuming the list from | |
| 205 | -- left to right while tracking some state: | |
| 206 | -- | |
| 207 | -- roof - as noted, the upper limit to the value of operator | |
| 208 | -- that we accept. When we see it, we return the | |
| 209 | -- built tree and the rest of the list to our caller. | |
| 210 | -- bigOp - the biggest operator we have seen in the list so | |
| 211 | -- far, locally speaking. That is, it will always be | |
| 212 | -- smaller than the roof value. It is used to decide | |
| 213 | -- when to start building a subtree. | |
| 214 | -- bigTree - the tree value associated with bigOp; acts more or | |
| 215 | -- less like an accumulator. | |
| 216 | -- prevAtom - needed to get the variables into the leaves of the | |
| 217 | -- tree where they logically belong. (The left | |
| 218 | -- subtree of the bottom branch actually needs the | |
| 219 | -- variable that is paired with the previous operator | |
| 220 | -- in the list.) | |
| 221 | -- | |
| 222 | -- During the loop, behaviour is split into three cases: | |
| 223 | -- | |
| 224 | -- Case 1: the operator exceeds the roof; return. | |
| 225 | -- Case 2: the operator is bigger than the biggest operator | |
| 226 | -- seen so far. Use it as the biggest operator, construct | |
| 227 | -- a tree node for it for use as the biggest tree, and | |
| 228 | -- loop around to tackle the next operator in the list. | |
| 229 | -- Case 3: the operator is smaller than the biggest operator | |
| 230 | -- seen so far. Create a subtree by recursively calling | |
| 231 | -- buildTreeLoop. For this call, the roof value is given | |
| 232 | -- by the biggest operator, and the biggest operator is | |
| 233 | -- initially set back to zero. The returned subtree is | |
| 234 | -- spliced into the biggest tree, as the right child. | |
| 235 | -- The loop then continues. The altered biggest tree, | |
| 236 | -- and the amount of the list consumed by the creation of | |
| 237 | -- the subtree are taken into account for the next loop | |
| 238 | -- iteration, but the roof and biggest operator do not | |
| 239 | -- change. | |
| 240 | -- | |
| 241 | ||
| 242 | buildTree [] roof bigOp bigTree prevAtom = | |
| 243 | (bigTree, []) | |
| 244 | buildTree pairs@((op, atom):restOfPairs) roof bigOp bigTree prevAtom | |
| 245 | | isGreater op roof = | |
| 246 | (bigTree, pairs) | |
| 247 | | op > bigOp = | |
| 248 | let | |
| 249 | newBigTree = TreeBranch bigTree atom | |
| 250 | in | |
| 251 | buildTree restOfPairs roof op newBigTree atom | |
| 252 | | op < bigOp = | |
| 253 | let | |
| 254 | (subTree, newPairs) = buildTree pairs (Finite bigOp) 0 prevAtom atom | |
| 255 | (TreeBranch bigTreeLeft bigTreeRight) = bigTree | |
| 256 | newBigTree = (TreeBranch bigTreeLeft subTree) | |
| 257 | in | |
| 258 | buildTree newPairs roof bigOp newBigTree atom | |
| 259 | ||
| 260 | -- | |
| 261 | -- Parse a Hev program into a valueless tree. | |
| 262 | -- | |
| 263 | ||
| 264 | parse string = | |
| 265 | fst (buildTree (stringToPairs string) Infinity 0 TreeLeaf TreeLeaf) | |
| 266 | ||
| 267 | ||
| 268 | ----------------------------------------------------------------------- | |
| 269 | -- ======================= Static Checker ========================== -- | |
| 270 | ----------------------------------------------------------------------- | |
| 271 | ||
| 272 | -- | |
| 273 | -- Return a list of all variables that occur in a given tree. | |
| 274 | -- | |
| 275 | ||
| 276 | getVariables TreeLeaf = [] | |
| 277 | getVariables (TreeVar var) = [var] | |
| 278 | getVariables (TreeBranch left right) = | |
| 279 | (getVariables left) ++ (getVariables right) | |
| 280 | ||
| 281 | -- | |
| 282 | -- Determine whether every element of the first list is also an element | |
| 283 | -- of the second list. | |
| 284 | -- | |
| 285 | ||
| 286 | isSubset [] _ = True | |
| 287 | isSubset (first:rest) list = | |
| 288 | (elem first list) && (isSubset rest list) | |
| 289 | where | |
| 290 | elem x [] = False | |
| 291 | elem x (first:rest) | |
| 292 | | x == first = True | |
| 293 | | otherwise = elem x rest | |
| 294 | ||
| 295 | -- | |
| 296 | -- Determine whether a tree is "ground", i.e. contains no variables. | |
| 297 | -- | |
| 298 | ||
| 299 | isGround tree = getVariables tree == [] | |
| 300 | ||
| 301 | -- | |
| 302 | -- Determine whether a set of rules is complete (each rule is complete, | |
| 303 | -- and the tree by which the ruleset itself is represented doesn't have | |
| 304 | -- any variables.) | |
| 305 | -- | |
| 306 | ||
| 307 | rulesComplete TreeLeaf = True | |
| 308 | rulesComplete (TreeVar _) = False | |
| 309 | rulesComplete (TreeBranch left right) = | |
| 310 | ruleComplete right && rulesComplete left | |
| 311 | ||
| 312 | -- | |
| 313 | -- Determine whether a rule is complete (it has has both a head and a | |
| 314 | -- body, and there are no variables in the body that aren't in the head.) | |
| 315 | -- | |
| 316 | ||
| 317 | ruleComplete TreeLeaf = False | |
| 318 | ruleComplete (TreeVar _) = False | |
| 319 | ruleComplete (TreeBranch head body) = | |
| 320 | isSubset (getVariables body) (getVariables head) | |
| 321 | ||
| 322 | -- | |
| 323 | -- Parse and check a Hev program. Returns an illegal tree (which will | |
| 324 | -- cause a Haskell runtime pattern-match error later on) if there are | |
| 325 | -- static errors detected in the Hev program. | |
| 326 | -- | |
| 327 | ||
| 328 | compile string | |
| 329 | | not (isGround stateTree) = | |
| 330 | TreeLeaf | |
| 331 | | not (rulesComplete ruleTree) = | |
| 332 | TreeLeaf | |
| 333 | | otherwise = | |
| 334 | tree | |
| 335 | where | |
| 336 | tree@(TreeBranch ruleTree stateTree) = parse string | |
| 337 | ||
| 338 | ||
| 339 | ----------------------------------------------------------------------- | |
| 340 | -- ======================= Tree rewriting ========================== -- | |
| 341 | ----------------------------------------------------------------------- | |
| 342 | ||
| 343 | -- | |
| 344 | -- Given a variable and a unifier, get the value given in | |
| 345 | -- the unifier for than variable, or Nothing if it is not found. | |
| 346 | -- | |
| 347 | ||
| 348 | getBinding _ UnificationFailure = | |
| 349 | Nothing | |
| 350 | getBinding _ UnifierNil = | |
| 351 | Nothing | |
| 352 | getBinding targetVar (UnifierBinding sourceVar tree unifier) | |
| 353 | | targetVar == sourceVar = | |
| 354 | Just tree | |
| 355 | | otherwise = | |
| 356 | getBinding targetVar unifier | |
| 357 | ||
| 358 | -- | |
| 359 | -- Match a "pattern" tree (the first argument) to a "state" tree and | |
| 360 | -- return the most general unifier, or nothing. | |
| 361 | -- | |
| 362 | ||
| 363 | match _ _ UnificationFailure = UnificationFailure | |
| 364 | match TreeLeaf TreeLeaf unifier = unifier | |
| 365 | match (TreeBranch left1 right1) (TreeBranch left2 right2) unifier = | |
| 366 | let | |
| 367 | unifier2 = match left1 left2 unifier | |
| 368 | unifier3 = match right1 right2 unifier2 | |
| 369 | in | |
| 370 | unifier3 | |
| 371 | match (TreeVar var) subTree unifier | |
| 372 | | binding == Nothing = | |
| 373 | UnifierBinding var subTree unifier | |
| 374 | | binding /= Just subTree = | |
| 375 | UnificationFailure | |
| 376 | | otherwise = | |
| 377 | unifier | |
| 378 | where | |
| 379 | binding = getBinding var unifier | |
| 380 | match _ _ _ = UnificationFailure | |
| 381 | ||
| 382 | -- | |
| 383 | -- Given a tree containing variables and a unifier, construct | |
| 384 | -- a "ground" tree (one with no variables) by replacing each | |
| 385 | -- variable with the value associated with it in the unifier. | |
| 386 | -- | |
| 387 | ||
| 388 | expand TreeLeaf unifier = TreeLeaf | |
| 389 | expand (TreeBranch left right) unifier = | |
| 390 | TreeBranch (expand left unifier) (expand right unifier) | |
| 391 | expand (TreeVar var) unifier = | |
| 392 | let | |
| 393 | (Just subTree) = getBinding var unifier | |
| 394 | in | |
| 395 | subTree | |
| 396 | ||
| 397 | -- | |
| 398 | -- Try to match the given pattern (the head of a rule) in | |
| 399 | -- the given tree. If there are multiple places where | |
| 400 | -- the pattern might match the tree, only the topmost leftmost | |
| 401 | -- one is chosen. Then return a new tree with the matched | |
| 402 | -- portion replaced by the body (appropriately expanded | |
| 403 | -- with any matched variables) if a match succeeded, or | |
| 404 | -- the original tree if no match succeeded. In either case, | |
| 405 | -- a boolean indicating whether the match succeeded is | |
| 406 | -- returned as well. | |
| 407 | -- | |
| 408 | ||
| 409 | rewrite tree@(TreeBranch left right) head body | |
| 410 | | unifier /= UnificationFailure = | |
| 411 | (True, expand body unifier) | |
| 412 | | successLeft = | |
| 413 | (True, TreeBranch newSubTreeLeft right) | |
| 414 | | successRight = | |
| 415 | (True, TreeBranch left newSubTreeRight) | |
| 416 | | otherwise = | |
| 417 | (False, tree) | |
| 418 | where | |
| 419 | unifier = match head tree UnifierNil | |
| 420 | (successLeft, newSubTreeLeft) = (rewrite left head body) | |
| 421 | (successRight, newSubTreeRight) = (rewrite right head body) | |
| 422 | ||
| 423 | rewrite tree head body | |
| 424 | | unifier /= UnificationFailure = | |
| 425 | (True, expand body unifier) | |
| 426 | | otherwise = | |
| 427 | (False, tree) | |
| 428 | where | |
| 429 | unifier = match head tree UnifierNil | |
| 430 | ||
| 431 | ||
| 432 | ----------------------------------------------------------------------- | |
| 433 | -- =========================== Execution =========================== -- | |
| 434 | ----------------------------------------------------------------------- | |
| 435 | ||
| 436 | -- | |
| 437 | -- A program is represented by | |
| 438 | -- | |
| 439 | -- _______root_______ | |
| 440 | -- / \ | |
| 441 | -- X ...state... | |
| 442 | -- / \ | |
| 443 | -- X rule | |
| 444 | -- / \ | |
| 445 | -- ... rule | |
| 446 | -- | |
| 447 | ||
| 448 | -- | |
| 449 | -- Each rule is represented by | |
| 450 | -- | |
| 451 | -- __rule__ | |
| 452 | -- / \ | |
| 453 | -- head body | |
| 454 | -- | |
| 455 | -- where the head is the pattern which will be matched against the | |
| 456 | -- state, and the body is the replacement which will be substituted. | |
| 457 | -- | |
| 458 | ||
| 459 | -- | |
| 460 | -- Here's how the interpreter works: | |
| 461 | -- | |
| 462 | -- Assemble a working list of rules (initially all rules.) | |
| 463 | -- | |
| 464 | -- Pick the first available rule from the working list of rules. | |
| 465 | -- | |
| 466 | -- Match the head of the rule against the state tree. | |
| 467 | -- | |
| 468 | -- If there was a match, replace the matched portion with an | |
| 469 | -- appropriate instantiation of the body of the rule, and repeat | |
| 470 | -- from the very beginning. | |
| 471 | -- | |
| 472 | -- If there was no match, remove this pattern from the working list of | |
| 473 | -- patterns and try again with the shorter working list. | |
| 474 | -- | |
| 475 | -- If this was the last working pattern, end. | |
| 476 | -- | |
| 477 | ||
| 478 | run (TreeBranch patternTree stateTree) = | |
| 479 | loop patternTree patternTree stateTree | |
| 480 | where | |
| 481 | loop TreeLeaf all state = state | |
| 482 | loop (TreeBranch rest pat@(TreeBranch head body)) all state | |
| 483 | | matched = | |
| 484 | loop all all state' | |
| 485 | | otherwise = | |
| 486 | loop rest all state | |
| 487 | where | |
| 488 | (matched, state') = rewrite state head body |
| 0 | 0 | #!/bin/sh |
| 1 | 1 | |
| 2 | falderal tests/Hev.markdown | |
| 2 | if [ x`which ghc` = x -a x`which runhugs` = x ]; then | |
| 3 | echo "Neither ghc nor runhugs found on search path" | |
| 4 | exit 1 | |
| 5 | fi | |
| 6 | ||
| 7 | touch fixture.markdown | |
| 8 | ||
| 9 | if [ ! x`which ghc` = x ]; then | |
| 10 | cat >>fixture.markdown <<EOF | |
| 11 | -> Functionality "Parse Hev Program" is implemented by | |
| 12 | -> shell command | |
| 13 | -> "ghc src/Hev.hs -e "parse \"%(test-text)\""" | |
| 14 | ||
| 15 | -> Functionality "Compile Hev Program" is implemented by | |
| 16 | -> shell command | |
| 17 | -> "ghc src/Hev.hs -e "compile \"%(test-text)\""" | |
| 18 | ||
| 19 | -> Functionality "Hev Binding" is implemented by | |
| 20 | -> shell command | |
| 21 | -> "ghc src/Hev.hs -e "getBinding \"%(test-text)\" (UnifierBinding \"-\" TreeLeaf (UnifierBinding \"+\" (TreeBranch TreeLeaf TreeLeaf) UnifierNil))"" | |
| 22 | ||
| 23 | -> Functionality "Hev Matching" is implemented by | |
| 24 | -> shell command | |
| 25 | -> "ghc src/Hev.hs -e "match %(test-text)"" | |
| 26 | ||
| 27 | -> Functionality "Hev Rewriting" is implemented by | |
| 28 | -> shell command | |
| 29 | -> "ghc src/Hev.hs -e "rewrite %(test-text)"" | |
| 30 | ||
| 31 | -> Functionality "Hev Execution" is implemented by | |
| 32 | -> shell command | |
| 33 | -> "ghc src/Hev.hs -e "run (compile \"%(test-text)\")"" | |
| 34 | ||
| 35 | EOF | |
| 36 | fi | |
| 37 | ||
| 38 | if [ ! x`which runhugs` = x ]; then | |
| 39 | cat >>fixture.markdown <<EOF | |
| 40 | -> Functionality "Parse Hev Program" is implemented by | |
| 41 | -> shell command | |
| 42 | -> "runhugs src/Main.hs parse %(test-body-file)" | |
| 43 | ||
| 44 | -> Functionality "Compile Hev Program" is implemented by | |
| 45 | -> shell command | |
| 46 | -> "runhugs src/Main.hs compile %(test-body-file)" | |
| 47 | ||
| 48 | -> Functionality "Hev Binding" is implemented by | |
| 49 | -> shell command | |
| 50 | -> "runhugs src/Main.hs getbinding %(test-body-file)" | |
| 51 | ||
| 52 | -> Functionality "Hev Matching" is implemented by | |
| 53 | -> shell command | |
| 54 | -> "runhugs src/Main.hs match %(test-body-file)" | |
| 55 | ||
| 56 | -> Functionality "Hev Rewriting" is implemented by | |
| 57 | -> shell command | |
| 58 | -> "runhugs src/Main.hs rewrite %(test-body-file)" | |
| 59 | ||
| 60 | -> Functionality "Hev Execution" is implemented by | |
| 61 | -> shell command | |
| 62 | -> "runhugs src/Main.hs run %(test-body-file)" | |
| 63 | ||
| 64 | EOF | |
| 65 | fi | |
| 66 | ||
| 67 | falderal fixture.markdown tests/Hev.markdown | |
| 68 | rm -f fixture.markdown |
| 9 | 9 | |
| 10 | 10 | -> Tests for functionality "Parse Hev Program" |
| 11 | 11 | |
| 12 | -> Functionality "Parse Hev Program" is implemented by | |
| 13 | -> shell command | |
| 14 | -> "ghc src/hev.hs -e "parse \"%(test-text)\""" | |
| 15 | ||
| 16 | 12 | | 1+2*3 |
| 17 | 13 | = TreeBranch (TreeBranch (TreeBranch TreeLeaf (TreeVar "+")) (TreeVar "*")) TreeLeaf |
| 18 | 14 | |
| 39 | 35 | |
| 40 | 36 | -> Tests for functionality "Compile Hev Program" |
| 41 | 37 | |
| 42 | -> Functionality "Compile Hev Program" is implemented by | |
| 43 | -> shell command | |
| 44 | -> "ghc src/hev.hs -e "compile \"%(test-text)\""" | |
| 45 | ||
| 46 | 38 | Good. |
| 47 | 39 | |
| 48 | 40 | | 43,13,23,53,33 |
| 68 | 60 | |
| 69 | 61 | -> Tests for functionality "Hev Binding" |
| 70 | 62 | |
| 71 | -> Functionality "Hev Binding" is implemented by | |
| 72 | -> shell command | |
| 73 | -> "ghc src/hev.hs -e "getBinding \"%(test-text)\" (UnifierBinding \"-\" TreeLeaf (UnifierBinding \"+\" (TreeBranch TreeLeaf TreeLeaf) UnifierNil))"" | |
| 74 | ||
| 75 | 63 | | + |
| 76 | 64 | = Just (TreeBranch TreeLeaf TreeLeaf) |
| 77 | 65 | |
| 85 | 73 | ------------ |
| 86 | 74 | |
| 87 | 75 | -> Tests for functionality "Hev Matching" |
| 88 | ||
| 89 | -> Functionality "Hev Matching" is implemented by | |
| 90 | -> shell command | |
| 91 | -> "ghc src/hev.hs -e "match %(test-text)"" | |
| 92 | 76 | |
| 93 | 77 | | (TreeLeaf) (TreeLeaf) UnifierNil |
| 94 | 78 | = UnifierNil |
| 121 | 105 | |
| 122 | 106 | -> Tests for functionality "Hev Rewriting" |
| 123 | 107 | |
| 124 | -> Functionality "Hev Rewriting" is implemented by | |
| 125 | -> shell command | |
| 126 | -> "ghc src/hev.hs -e "rewrite %(test-text)"" | |
| 127 | ||
| 128 | 108 | | (TreeBranch TreeLeaf TreeLeaf) |
| 129 | 109 | | (TreeBranch TreeLeaf TreeLeaf) |
| 130 | 110 | | TreeLeaf |
| 144 | 124 | ------------- |
| 145 | 125 | |
| 146 | 126 | -> Tests for functionality "Hev Execution" |
| 147 | ||
| 148 | -> Functionality "Hev Execution" is implemented by | |
| 149 | -> shell command | |
| 150 | -> "ghc src/hev.hs -e "run (compile \"%(test-text)\")"" | |
| 151 | 127 | |
| 152 | 128 | Test a very simple (and completely ground) program. |
| 153 | 129 | |