Commit f7bb13908544ade4fa1902f40a22f09ce3870c2a - Fountain

Another checkpoint. Need to unbreak single Alt elimination? Chris Pressey 1 year, 5 months ago

3 changed file(s) with 51 addition(s) and 23 deletion(s). Raw diff Collapse all Expand all

-17

src/Language/Fountain/Generator.hs less more

0	0	module Language.Fountain.Generator (constructState, generateFrom, obtainResult) where
1
2		import Data.Maybe (mapMaybe)
3	1
4	2	import Language.Fountain.Grammar
5	3	import Language.Fountain.Constraint

17	15	obtainResult :: GenState -> Either String String
18	16	obtainResult (Generating s _) = Right s
19	17	obtainResult Failure = Left "failure"
20
21		--
22		-- Alt choices need preconditions because in generating, unlike parsing,
23		-- we need some guidance of which one to pick
24		--
25		getPreCondition :: Expr -> Maybe Constraint
26		getPreCondition (Seq (x:_)) = getPreCondition x
27		getPreCondition (Constraint c) = Just c
28		getPreCondition _ = Nothing
29
30		missingPreConditions choices =
31		mapMaybe (\x -> case getPreCondition x of
32		Just _ -> Nothing
33		Nothing -> Just x
34		) choices
35	18
36	19
37	20	gen :: Grammar -> GenState -> Expr -> GenState

+25

-1

src/Language/Fountain/Grammar.hs less more

2	2	Expr(Seq, Alt, Loop, Terminal, NonTerminal, Constraint),
3	3	Production(Production, ntname, params, backtrackable, constituents),
4	4	Grammar(Grammar),
5		startSymbol, production, getFormals
	5	startSymbol, production, getFormals,
	6	getPreCondition, missingPreConditions
6	7	) where
7	8
8	9	import Data.List (intercalate)
	10	import Data.Maybe (mapMaybe)
9	11
10	12	import Language.Fountain.Constraint
11	13

56	58	show (Grammar []) = ""
57	59	show (Grammar (prod:rest)) = (show prod) ++ (show $ Grammar rest)
58	60
	61	--
	62	-- Accessors and utilities
	63	--
59	64
60	65	startSymbol :: Grammar -> NTName
61	66	startSymbol (Grammar (prod : _)) = ntname prod

70	75	getFormals nt (Grammar (prod : rest)) =
71	76	if nt == (ntname prod) then params prod else getFormals nt (Grammar rest)
72	77	getFormals nt (Grammar []) = error ("Production '" ++ nt ++ "' not found")
	78
	79	--
	80	-- Alt choices need preconditions because, especially in generating,
	81	-- we need some guidance of which one to pick.
	82	--
	83	-- In parsing too though, it helps for being efficient and not
	84	-- backtracking unnecessarily. (But we need a more refined notion
	85	-- in this case, because a terminal counts as a precondition. TODO.)
	86	--
	87	getPreCondition :: Expr -> Maybe Constraint
	88	getPreCondition (Seq (x:_)) = getPreCondition x
	89	getPreCondition (Constraint c) = Just c
	90	getPreCondition _ = Nothing
	91
	92	missingPreConditions choices =
	93	mapMaybe (\x -> case getPreCondition x of
	94	Just _ -> Nothing
	95	Nothing -> Just x
	96	) choices

+26

-5

src/Language/Fountain/Parser.hs less more

31	31	st' -> parseSeq st' rest
32	32
33	33	-- Hello, Mrs Backtracking Alternation!
34		parse g state (Alt True s) = parseAlt state s where
	34	parse g state (Alt True choices) = parseAlt state choices where
	35	-- FIXME: select only the choices that could possibly apply
35	36	parseAlt _st [] = Failure
36	37	parseAlt st (e : rest) =
37	38	case parse g st e of

39	40	st' -> st'
40	41
41	42	-- Hello, Mrs Non-Backtracking Alternation!
42		parse g state (Alt False s) = parseAlt state s where
43		parseAlt _st [] = Failure
44		-- FIXME: this should do "pick an applicable one"
45		parseAlt st (e : _) = parse g st e
	43	parse g state@(Parsing _str store) (Alt False choices) =
	44	case missingPreConditions choices of
	45	missing@(_:_) ->
	46	error ("No pre-condition present on these Alt choices: " ++ (show missing))
	47	[] ->
	48	let
	49	preConditionedChoices = map (\x -> (getPreCondition x, x)) choices
	50	isApplicableChoice (Just c, _) = canApplyConstraint c store
	51	isApplicableChoice _ = False
	52	applicableChoices = filter (isApplicableChoice) preConditionedChoices
	53	in
	54	parseAlt state applicableChoices where
	55	where
	56	parseAlt _st [] = Failure
	57	-- we ignore the constraint here because it will be found and applied when we descend into e
	58	parseAlt st [(_, e)] = parse g st e
	59	parseAlt _st other =
	60	error ("Multiple pre-conditions are satisfied in Alt: " ++ (show other))
46	61
47	62	parse g state (Loop l _) = parseLoop state l where
48	63	parseLoop st e =

123	138	_ ->
124	139	Nothing
125	140
	141	canApplyConstraint c store =
	142	case applyConstraint c store of
	143	Just _ -> True
	144	Nothing -> False
	145
	146
126	147	constructState :: String -> [String] -> ParseState
127	148	constructState text initialParams = Parsing text $ constructStore initialParams
128	149