Commit 33f23d133b57838a125ab756ace3e032dea7fcb0 - Fountain

+8

-12

src/Language/Fountain/Generator.hs less more

36	36	genTerminal :: Char -> GenState -> GenState
37	37	genTerminal c state@Generating{ text=text } = state{ text=(c:text) }
38	38
39		--
40		-- Alt choices heed preconditions to prevent unnecessary backtracking.
41		--
42		getPreCondition :: Expr -> Constraint Value
43		getPreCondition (Seq (x:_)) = getPreCondition x
44		getPreCondition (Constraint c) = c
45		getPreCondition _ = Identity
46
47		getApplicableChoices store choices =
	39	getApplicableChoices state choices =
48	40	let
49	41	preConditionedChoices = map (\x -> (getPreCondition x, x)) choices
50		isApplicableChoice (c, _) = can $ applyConstraint c store
	42	isApplicableChoice (c, _) = can $ applyGenConstraint c state
51	43	in
52	44	filter (isApplicableChoice) preConditionedChoices
	45
	46	applyGenConstraint :: Constraint Value -> Store Value -> Maybe (Store Value)
	47	applyGenConstraint (Lookahead _) store = Just store
	48	applyGenConstraint other store = applyConstraint other store
53	49
54	50	scramble :: [a] -> GenState -> ([a], GenState)
55	51	scramble choices state@Generating{ prng=prng } =

118	114	Nothing -> genLoop st' e
119	115	checkLimit [] st = Just st
120	116	checkLimit (c:cs) st =
121		case applyConstraint c st of
	117	case applyGenConstraint c st of
122	118	Nothing -> Nothing
123	119	Just st' -> checkLimit cs st'
124	120

138	134	Left x
139	135
140	136	gen _g st@Generating{ store=store } (Constraint cstr) =
141		case applyConstraint cstr store of
	137	case applyGenConstraint cstr store of
142	138	Just store' ->
143	139	-- TODO st{ trace=(("OK " ++ depictConstraint cstr):trace), store=store' }
144	140	Right $ st{ store=store' }

+9

-0

src/Language/Fountain/Grammar.hs less more

9	9	Grammar(Grammar),
10	10	depictExpr, depictExprs, depictProduction, depictGrammar, depictVars,
11	11	startSymbol, productionExpr, productionParams, getFormals,
	12	getPreCondition
12	13	) where
13	14
14	15	import Data.List (intercalate)

93	94	if nt == (ntname prod) then params prod else getFormals nt (Grammar rest)
94	95	getFormals nt (Grammar []) = error ("Production '" ++ nt ++ "' not found")
95	96
	97	--
	98	-- Alt choices heed preconditions to prevent unnecessary backtracking.
	99	--
	100	getPreCondition :: Expr -> Constraint Value
	101	getPreCondition (Seq (x:_)) = getPreCondition x
	102	getPreCondition (Constraint c) = c
	103	getPreCondition (Terminal c) = Lookahead s where s = [c]
	104	getPreCondition _ = Identity

+11

-21

src/Language/Fountain/Parser.hs less more

30	30	expectTerminal _tc (Parsing [] _a) =
31	31	Left "end of string"
32	32
33		--
34		-- Alt choices heed preconditions to prevent unnecessary backtracking.
35		--
36		getPreCondition :: Expr -> Constraint Value
37		getPreCondition (Seq (x:_)) = getPreCondition x
38		getPreCondition (Constraint c) = c
39		getPreCondition (Terminal c) = Lookahead s where s = [c]
40		getPreCondition _ = Identity
41
42	33	getApplicableChoices state choices =
43	34	let
44	35	preConditionedChoices = map (\x -> (getPreCondition x, x)) choices
45	36	isApplicableChoice (c, _) = can $ applyParseConstraint c state
46	37	in
47	38	filter (isApplicableChoice) preConditionedChoices
	39
	40	applyParseConstraint :: Constraint Value -> ParseState -> ParseResult
	41	applyParseConstraint (Lookahead s) state@(Parsing (c:_) _) =
	42	if s == [c] then (Right state) else (Left "lookahead failed")
	43	applyParseConstraint (Lookahead _) _ = Left "lookahead failed"
	44	applyParseConstraint other (Parsing s store) =
	45	case applyConstraint other store of
	46	Just store' ->
	47	Right $ Parsing s store'
	48	Nothing ->
	49	Left "constraint failed"
48	50
49	51	--
50	52	-- Parser

107	109
108	110	parse _g state (Constraint cstr) = applyParseConstraint cstr state
109	111
110
111		applyParseConstraint :: Constraint Value -> ParseState -> ParseResult
112		applyParseConstraint (Lookahead s) state@(Parsing (c:_) _) =
113		if s == [c] then (Right state) else (Left "lookahead failed")
114		applyParseConstraint (Lookahead _) _ = Left "lookahead failed"
115		applyParseConstraint other (Parsing s store) =
116		case applyConstraint other store of
117		Just store' ->
118		Right $ Parsing s store'
119		Nothing ->
120		Left "constraint failed"
121
122	112	--
123	113	-- Usage interface
124	114	--