From f298fcb268dbd4fe74d752077f8f012532d095c1 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Mon, 14 Apr 2014 00:07:24 +1000
Subject: Interpreter can now handle literal strings to avoid code injection
---
src/Thue/Interpreter.hs | 41 +++++++++++++++++++++++++++++++----------
src/Thue/Parser.hs | 28 +++++++++++++---------------
2 files changed, 44 insertions(+), 25 deletions(-)
(limited to 'src/Thue')
diff --git a/src/Thue/Interpreter.hs b/src/Thue/Interpreter.hs
index 28aff93..3e82826 100644
--- a/src/Thue/Interpreter.hs
+++ b/src/Thue/Interpreter.hs
@@ -12,6 +12,15 @@ import Thue.Parser
+data ThueVersion = Ver1 | Ver2a
+ deriving (Eq)
+
+
+data Choice = Random StdGen
+ | First
+ | Last
+
+
thue :: ThueProgram -> IO ThueState
thue program =
@@ -19,30 +28,42 @@ thue program =
state = thueInitialState program
gen = mkStdGen 4 --chosen by fair dice roll, guaranteed to be random
- in interpret state rules gen
+ in interpret Ver1 rules (Random gen) state
-interpret :: ThueState -> [ThueRule] -> StdGen -> IO ThueState
-interpret state rules gen =
+interpret :: ThueVersion -> [ThueRule] -> Choice -> ThueState -> IO ThueState
+interpret ver rules gen state =
let possibleRules = rules `applicableTo` state
- ruleToApply = possibleRules !! num
-
- (num, gen') = nextInRange 0 (length possibleRules - 1) gen
+ (ruleToApply, gen') = choose possibleRules gen
in if (possibleRules == [])
then return state
- else applyRule ruleToApply state >>= (\x -> interpret x rules gen')
+ else applyRule ver ruleToApply state >>= interpret ver rules gen'
+
+choose :: [ThueRule] -> Choice -> (ThueRule, Choice)
+choose ruleList gen =
+ case gen of
+ First -> (head ruleList, First)
-applyRule :: ThueRule -> ThueState -> IO ThueState
-applyRule rule state =
+ Last -> (last ruleList, Last)
+
+ Random g -> let (num, g') = nextInRange 0 (length ruleList - 1) g
+ in (ruleList !! num, Random g')
+
+
+
+applyRule :: ThueVersion -> ThueRule -> ThueState -> IO ThueState
+applyRule ver rule state =
let (before, after) = fromJust (extractInfix (original rule) state)
+ inputProc = if (ver == Ver1) then return . tStr else return . tLitStr
+
in case (replacement rule) of
x | x == (tStr ":::") ->
- getLine >>= return . toThueState >>= return . (before ++) . (++ after)
+ getLine >>= inputProc >>= return . (before ++) . (++ after)
x:xs | x == (tCh '~') ->
putStr (fromThueState xs) >> return (before ++ after)
diff --git a/src/Thue/Parser.hs b/src/Thue/Parser.hs
index 3ca937e..a9c2d96 100644
--- a/src/Thue/Parser.hs
+++ b/src/Thue/Parser.hs
@@ -4,11 +4,12 @@ module Thue.Parser (
ThueState,
ThueChar(..),
- tCh,
- tStr,
-
parseThue,
- toThueState,
+
+ tCh,
+ tLit,
+ tStr,
+ tLitStr,
fromThueState
) where
@@ -48,24 +49,21 @@ parseThue = parse thue "error"
-toThueState :: String -> ThueState
-toThueState = map TChar
-
-
-
-fromThueState :: ThueState -> String
-fromThueState = map tChar
-
-
-
tCh :: Char -> ThueChar
tCh = TChar
-
+tLit :: Char -> ThueChar
+tLit = TLit
tStr :: String -> ThueState
tStr = map TChar
+tLitStr :: String -> ThueState
+tLitStr = map TLit
+
+fromThueState :: ThueState -> String
+fromThueState = map tChar
+
--
cgit