Commit 081fee60ef23800fd1407dd3d7c3d35e50bc03cf - Fountain

+5

-0

.gitignore less more

	0	*.exe
	1	*.hi
	2	*.o
	3	demo/tandem.js
	4	*.jsmod

+64

-0

README.md less more

	0	Fountain
	1	========
	2
	3	Fountain is a work-in-progress grammar formalism capable of expressing
	4	context-sensitive languages (CSLs) and supporting both efficient parsing
	5	_and_ efficient generation of sentential forms of those languages.
	6
	7	It does this by allowing semantic actions to be interspersed between
	8	the terms of a production rule. Unlike the imperative semantic actions in a
	9	typical parser-generator (such as `yacc`) though, these actions are
	10	relational, and are also called _constraints_. This situates Fountain
	11	closer to the Definite Clause Grammars (DCGs) or Attribute Grammars (AGs).
	12
	13	To support efficient generation, the interspersed semantic actions
	14	are analyzed to determine a plausible deterministic strategy for generation.
	15
	16	Here is an example Fountain grammar which expresses the classic CSL
	17	`a`^_n_ `b`^_n_ `c`^_n_:
	18
	19	Goal ::= <. arb n .>
	20	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	21	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	22	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	23	;
	24
	25	During parsing based on this grammar, the `arb n` constraint is
	26	ignored and leaves `a` undefined. The first time `a = n` is
	27	encountered, `a` will be unified with `n`, and will take on its
	28	value. When `b = n` is later encountered, unification of `b`
	29	with `n` will take place; if `b` is some value other than `n`,
	30	the parse will fail.
	31
	32	% ./bin/fountain parse eg/anbncn.fountain anbncn.txt
	33	Success
	34
	35	In comparison, during generation, `arb n` will cause `n` to take on
	36	an arbitrary (for example, random) value. In addition, the
	37	repetition construct `{ "a" <. a += 1 .> }` can "see" the
	38	following `a = n` constraint, will check it on each iteration,
	39	and will terminate when it is true.
	40
	41	% ./bin/fountain generate eg/anbncn.fountain
	42	aaaaabbbbbccccc
	43
	44	Neither of the above processes involve backtracking; the string
	45	is parsed or generated in linear time. However, it is important to note
	46	that, while Fountain supports deterministic, it does not enforce it.
	47	It is possible to write Fountain grammars that lead to backtracking
	48	search, or even infinite loops during generation. How best to handle
	49	these cases remains an open line of inquiry.
	50
	51	For a fuller description of the Fountain language, see
	52	[doc/Definition-of-Fountain.md](doc/Definition-of-Fountain.md).
	53
	54	TODO
	55	----
	56
	57	* Need to understand why the anbncn parser fails when given only "aaabbbccc" with no further characters. (See test suite)
	58	* Failure should produce nonzero exit code.
	59	* Terminals should be multi-character in the syntax.
	60	* Rename "arb" to "param" (?)
	61	* Allow params to be supplied.
	62	* `fountain parse` should be able to read the input string from stdin.
	63	* Check constraints on all branches of an alternation.

+18

-0

bin/fountain less more

	0	#!/bin/sh
	1
	2	THIS=`realpath $0`
	3	DIR=`dirname $THIS`
	4	NAME=`basename $THIS`
	5	SRC=$DIR/../src
	6	if [ "x$FORCE_HUGS" != "x" ] ; then
	7	exec runhugs -i$SRC $SRC/Main.hs $*
	8	elif [ -x $DIR/$NAME.exe ] ; then
	9	exec $DIR/$NAME.exe $*
	10	elif command -v runhaskell 2>&1 >/dev/null ; then
	11	exec runhaskell -i$SRC $SRC/Main.hs $*
	12	elif command -v runhugs 2>&1 >/dev/null ; then
	13	exec runhugs -i$SRC $SRC/Main.hs $*
	14	else
	15	echo "Cannot run $NAME; neither $NAME.exe, nor runhaskell, nor runhugs found."
	16	exit 1
	17	fi

+17

-0

build.sh less more

	0	#!/bin/sh
	1
	2	PROG=fountain
	3
	4	if command -v ghc >/dev/null 2>&1; then
	5	echo "building $PROG.exe with ghc"
	6	(cd src && ghc --make Main.hs -o ../bin/$PROG.exe)
	7	else
	8	echo "ghc not found, not building $PROG.exe"
	9	fi
	10
	11	# if command -v hastec >/dev/null 2>&1; then
	12	# echo "building $PROG.js with hastec"
	13	# (cd src && hastec --make HasteMain.hs -o $PROG.js && mv $PROG.js ../demo/)
	14	# else
	15	# echo "hastec not found, not building $PROG.js"
	16	# fi

+171

-0

doc/Definition-of-Fountain.md less more

	0	Fountain Definition
	1	===================
	2
	3	This document defines the Fountain Grammar Formalism.
	4
	5	It does this in part by test cases. These test cases
	6	are written in Falderal format.
	7
	8	The Tests
	9	---------
	10
	11	-> Functionality "Load Fountain Grammar" is implemented by
	12	-> shell command "bin/fountain load %(test-body-file)"
	13
	14	-> Functionality "Preprocess Fountain Grammar" is implemented by
	15	-> shell command "bin/fountain preprocess %(test-body-file)"
	16
	17	-> Functionality "Parse using Fountain Grammar" is implemented by
	18	-> shell command "bin/fountain parse %(test-body-file) %(test-input-file)"
	19
	20	-> Functionality "Generate using Fountain Grammar" is implemented by
	21	-> shell command "bin/fountain generate %(test-body-file)"
	22
	23	### Loading
	24
	25	-> Tests for functionality "Load Fountain Grammar"
	26
	27	Sequence.
	28
	29	Goal ::= "f" "o" "o";
	30	===> Grammar [(NT "Goal",Alt [Seq [Term (T 'f'),Term (T 'o'),Term (T 'o')]])]
	31
	32	Alternation and recursion.
	33
	34	Goal ::= "(" Goal ")" \| "0";
	35	===> Grammar [(NT "Goal",Alt [Seq [Term (T '('),Term (NT "Goal"),Term (T ')')],Seq [Term (T '0')]])]
	36
	37	Repetition.
	38
	39	Goal ::= "(" {"0"} ")";
	40	===> Grammar [(NT "Goal",Alt [Seq [Term (T '('),Loop (Alt [Seq [Term (T '0')]]) [],Term (T ')')]])]
	41
	42	Constraints.
	43
	44	Goal ::= <. arb n .>
	45	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	46	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	47	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	48	;
	49	===> Grammar [(NT "Goal",Alt [Seq [Constraint (Arb (Var "n")),Constraint (UnifyConst (Var "a") 0),Loop (Alt [Seq [Term (T 'a'),Constraint (Inc (Var "a") 1)]]) [],Constraint (UnifyVar (Var "a") (Var "n")),Constraint (UnifyConst (Var "b") 0),Loop (Alt [Seq [Term (T 'b'),Constraint (Inc (Var "b") 1)]]) [],Constraint (UnifyVar (Var "b") (Var "n")),Constraint (UnifyConst (Var "c") 0),Loop (Alt [Seq [Term (T 'c'),Constraint (Inc (Var "c") 1)]]) [],Constraint (UnifyVar (Var "c") (Var "n"))]])]
	50
	51	### Preprocessing
	52
	53	-> Tests for functionality "Preprocess Fountain Grammar"
	54
	55	Sequence.
	56
	57	Goal ::= "f" "o" "o";
	58	===> Grammar [(NT "Goal",Alt [Seq [Term (T 'f'),Term (T 'o'),Term (T 'o')]])]
	59
	60	Alternation and recursion.
	61
	62	Goal ::= "(" Goal ")" \| "0";
	63	===> Grammar [(NT "Goal",Alt [Seq [Term (T '('),Term (NT "Goal"),Term (T ')')],Seq [Term (T '0')]])]
	64
	65	Repetition.
	66
	67	Goal ::= "(" {"0"} ")";
	68	===> Grammar [(NT "Goal",Alt [Seq [Term (T '('),Loop (Alt [Seq [Term (T '0')]]) [],Term (T ')')]])]
	69
	70	Goal ::= <. arb n .>
	71	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	72	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	73	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	74	;
	75	===> Grammar [(NT "Goal",Alt [Seq [Constraint (Arb (Var "n")),Constraint (UnifyConst (Var "a") 0),Loop (Alt [Seq [Term (T 'a'),Constraint (Inc (Var "a") 1)]]) [UnifyVar (Var "a") (Var "n"),UnifyConst (Var "b") 0],Loop (Alt [Seq [Term (T 'b'),Constraint (Inc (Var "b") 1)]]) [UnifyVar (Var "b") (Var "n"),UnifyConst (Var "c") 0],Loop (Alt [Seq [Term (T 'c'),Constraint (Inc (Var "c") 1)]]) [UnifyVar (Var "c") (Var "n")]]])]
	76
	77	### Parsing
	78
	79	-> Tests for functionality "Parse using Fountain Grammar"
	80
	81	Sequence.
	82
	83	Goal ::= "f" "o" "o";
	84	<=== foo
	85	===> Success
	86
	87	Goal ::= "f" "o" "o";
	88	<=== fog
	89	===> Failure
	90
	91	Alternation and recursion.
	92
	93	Goal ::= "(" Goal ")" \| "0";
	94	<=== (((0)))
	95	===> Success
	96
	97	Goal ::= "(" Goal ")" \| "0";
	98	<=== ()
	99	===> Failure
	100
	101	Goal ::= "(" Goal ")" \| "0";
	102	<=== 0
	103	===> Success
	104
	105	Repetition.
	106
	107	Goal ::= "(" {"0"} ")";
	108	<=== (0)
	109	===> Success
	110
	111	Goal ::= "(" {"0"} ")";
	112	<=== (000000)
	113	===> Success
	114
	115	Goal ::= "(" {"0"} ")";
	116	<=== ()
	117	===> Success
	118
	119	Goal ::= "(" {"0"} ")";
	120	<=== (00001)
	121	===> Failure
	122
	123	### Parsing with Constraints
	124
	125	TODO: Understand why this needs a space afterwards.
	126
	127	Goal ::= <. arb n .>
	128	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	129	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	130	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	131	;
	132	<=== aaabbbccc
	133	===> Remaining: " "
	134
	135	This one fails at the `<. b = n .>` constraint.
	136
	137	Goal ::= <. arb n .>
	138	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	139	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	140	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	141	;
	142	<=== aaabbccc
	143	===> Failure
	144
	145	### Generation
	146
	147	-> Tests for functionality "Generate using Fountain Grammar"
	148
	149	Sequence.
	150
	151	Goal ::= "f" "o" "o";
	152	===> foo
	153
	154	Alternation.
	155
	156	Goal ::= "f" \| "o";
	157	===> f
	158
	159	Goal ::= ("f" \| "o") ("a" \| "z");
	160	===> fa
	161
	162	Repetition. Without constraints, this will error out.
	163
	164	Goal ::= {"f"};
	165	???> No postconditions defined for this Loop
	166
	167	### Generation with Constraints
	168
	169	Goal ::= <. a = 0 .> { "a" <. a += 1 .> } <. a = 5 .>;
	170	===> aaaaa

+5

-0

eg/anbncn.fountain less more

	0	Goal ::= <. arb n .>
	1	<. a = 0 .> { "a" <. a += 1 .> } <. a = n .>
	2	<. b = 0 .> { "b" <. b += 1 .> } <. b = n .>
	3	<. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
	4	;

+1

-0

eg/trivial.fountain less more

0

Goal ::= "h" "i";

+14

-0

src/Language/Fountain/Constraint.hs less more

	0	module Language.Fountain.Constraint where
	1
	2
	3	data Variable = Var String
	4	deriving (Show, Ord, Eq)
	5
	6	data Constraint = UnifyConst Variable Integer
	7	\| UnifyVar Variable Variable
	8	\| Arb Variable
	9	\| Inc Variable Integer
	10	\| Dec Variable Integer
	11	\| GT Variable Integer
	12	\| LT Variable Integer
	13	deriving (Show, Ord, Eq)

+97

-0

src/Language/Fountain/Generator.hs less more

	0	module Language.Fountain.Generator (generateFrom, formatResult) where
	1
	2	import Language.Fountain.Grammar
	3	import Language.Fountain.Constraint
	4	import Language.Fountain.Store
	5
	6
	7	data GenState = Generating String Store
	8	\| Failure
	9	deriving (Show, Ord, Eq)
	10
	11
	12	genTerminal c (Generating cs a) = (Generating (c:cs) a)
	13
	14	formatResult (Generating s _) = s
	15
	16
	17	gen :: Grammar -> GenState -> Expr -> GenState
	18
	19	gen g st (Seq s) = genSeq g st s where
	20	genSeq g st [] = st
	21	genSeq g st (e : rest) =
	22	case gen g st e of
	23	Failure -> Failure
	24	st' -> genSeq g st' rest
	25
	26	-- FIXME: this should look at all the alts and
	27	-- each of those alts should start with pre-conditions
	28	-- and we should narrow which one down based on that.
	29	-- Then pick randomly.
	30	gen g st (Alt s) = genAlt g st s where
	31	genAlt g st [] = Failure
	32	genAlt g st (e : rest) =
	33	case gen g st e of
	34	Failure -> genAlt g st rest
	35	st' -> st'
	36
	37	gen g state (Loop l postconditions) =
	38	genLoop g state l (assertThereAreSome postconditions) where
	39	genLoop g state e postconditions =
	40	case gen g state e of
	41	Failure -> state
	42	state'@(Generating str store) ->
	43	case checkLimit postconditions store of
	44	-- All postconditions met, terminate the loop.
	45	Just store' -> Generating str store'
	46	-- Not all postconditions met -- go 'round again
	47	Nothing -> genLoop g state' e postconditions
	48	assertThereAreSome [] = error "No postconditions defined for this Loop"
	49	assertThereAreSome pcs = pcs
	50	checkLimit [] st = Just st
	51	checkLimit (c:cs) st =
	52	case applyConstraint c st of
	53	Nothing -> Nothing
	54	Just st' -> checkLimit cs st'
	55
	56	gen g st (Term t) = genTerm g st t where
	57	genTerm g st t@(T c) = genTerminal c st
	58	genTerm g st nt@(NT _) = gen g st (production nt g)
	59
	60	gen g st@(Generating text store) (Constraint cstr) =
	61	case applyConstraint cstr store of
	62	Just store' ->
	63	Generating text store'
	64	Nothing ->
	65	Failure
	66
	67	applyConstraint :: Constraint -> Store -> Maybe Store
	68	applyConstraint (UnifyConst v i) st =
	69	case fetch v st of
	70	Just value ->
	71	if value == i then Just st else Nothing
	72	Nothing ->
	73	Just $ insert v i st
	74	applyConstraint (UnifyVar v w) st =
	75	case (fetch v st, fetch w st) of
	76	(Just vValue, Just wValue) ->
	77	if vValue == wValue then Just st else Nothing
	78	(Just vValue, Nothing) ->
	79	Just $ insert w vValue st
	80	(Nothing, Just wValue) ->
	81	Just $ insert v wValue st
	82	(Nothing, Nothing) ->
	83	Just st
	84	applyConstraint (Arb v) st =
	85	-- TODO not always 5 :)
	86	Just $ insert v 5 st
	87	applyConstraint (Inc v i) st =
	88	Just $ update (\i -> Just (i + 1)) v st
	89	applyConstraint (Dec v i) st =
	90	Just $ update (\i -> Just (i - 1)) v st
	91
	92
	93	generateFrom :: Grammar -> GenState
	94	generateFrom g = revgen $ gen g (Generating "" empty) (production (startSymbol g) g)
	95	where
	96	revgen (Generating s a) = Generating (reverse s) a

+29

-0

src/Language/Fountain/Grammar.hs less more

	0	module Language.Fountain.Grammar where
	1
	2	import Language.Fountain.Constraint
	3
	4
	5	data Term = T Char
	6	\| NT String
	7	deriving (Show, Ord, Eq)
	8
	9	data Expr = Seq [Expr]
	10	\| Alt [Expr]
	11	\| Loop Expr [Constraint] -- see below
	12	\| Term Term
	13	\| Constraint Constraint
	14	deriving (Show, Ord, Eq)
	15
	16	data Grammar = Grammar [(Term, Expr)]
	17	deriving (Show, Ord, Eq)
	18
	19
	20	startSymbol (Grammar ((term, _) : _)) = term
	21
	22	production nt (Grammar ((term, expr) : rest)) =
	23	if term == nt then expr else production nt (Grammar rest)
	24
	25
	26	-- In the case of a Loop, there will be a post-processing step
	27	-- that copies any constraints following the Loop, into the Loop
	28	-- itself. This is to make the generator's life easier.

+151

-0

src/Language/Fountain/Loader.hs less more

	0	{-# LANGUAGE FlexibleContexts #-}
	1	module Language.Fountain.Loader where
	2
	3	import Text.ParserCombinators.Parsec
	4	import Text.Parsec.Prim (ParsecT)
	5
	6	import Language.Fountain.Grammar
	7	import Language.Fountain.Constraint
	8
	9
	10	-- Grammar ::= {Production}.
	11	-- Production ::= NonTerminal "::=" {Expr0}.
	12	-- Expr0 ::= Expr1 {"\|" Expr1}.
	13	-- Expr1 ::= Term {Term}.
	14	-- Term ::= "{" Expr0 "}"
	15	-- \| "(" Expr0 ")"
	16	-- \| "<." Constraint ".>"
	17	-- \| Terminal
	18	-- \| NonTerminal.
	19	-- Constraint ::= Variable Constrainer.
	20	-- Constrainer ::= "arb" Variable
	21	-- \| "=" (Variable \| IntLit)
	22	-- \| "+=" IntLit
	23	-- \| "-=" IntLit
	24	-- \| ">" IntLit
	25	-- \| "<" IntLit.
	26
	27
	28	fountain = do
	29	ps <- many prod
	30	return (Grammar ps)
	31
	32	prod = do
	33	s <- capWord
	34	let nt = NT s
	35	keyword "::="
	36	e <- expr0
	37	keyword ";"
	38	return (nt, e)
	39
	40	expr0 = do
	41	es <- sepBy (expr1) (keyword "\|")
	42	return $ Alt es
	43
	44	expr1 = do
	45	es <- many1 term
	46	return $ Seq es
	47
	48	term = (try parenExpr) <\|> (try loopExpr) <\|> (try constraintExpr) <\|> (try terminal) <\|> nonterminal
	49
	50	parenExpr = do
	51	keyword "("
	52	e <- expr0
	53	keyword ")"
	54	return e
	55
	56	loopExpr = do
	57	keyword "{"
	58	e <- expr0
	59	keyword "}"
	60	return $ Loop e []
	61
	62	constraintExpr = do
	63	keyword "<."
	64	c <- constrainer
	65	keyword ".>"
	66	return $ Constraint $ c
	67
	68	constrainer = (try arb) <\|> (try unifyConst) <\|> (try unifyVar) <\|> (try inc) <\|> (try dec) -- <\|> (try gt) <\|> (try lt)
	69
	70	arb = do
	71	keyword "arb"
	72	v <- variable
	73	return $ Arb v
	74
	75	unifyConst = do
	76	v <- variable
	77	keyword "="
	78	n <- intlit
	79	return $ UnifyConst v n
	80
	81	unifyVar = do
	82	v <- variable
	83	keyword "="
	84	w <- variable
	85	return $ UnifyVar v w
	86
	87	inc = do
	88	v <- variable
	89	keyword "+="
	90	n <- intlit
	91	return $ Inc v n
	92
	93	dec = do
	94	v <- variable
	95	keyword "-="
	96	n <- intlit
	97	return $ Dec v n
	98
	99	variable = do
	100	s <- lowWord
	101	return $ Var s
	102
	103	terminal = do
	104	s <- quotedString
	105	return $ Term $ T (head s)
	106
	107	nonterminal = do
	108	s <- capWord
	109	return $ Term $ NT s
	110
	111	--
	112	-- Low level: Concrete things
	113	--
	114
	115	keyword s = do
	116	try (string s)
	117	spaces
	118
	119	capWord = do
	120	c <- upper
	121	s <- many (alphaNum)
	122	spaces
	123	return (c:s)
	124
	125	lowWord = do
	126	c <- lower
	127	s <- many (alphaNum)
	128	spaces
	129	return (c:s)
	130
	131	intlit = do
	132	c <- digit
	133	cs <- many digit
	134	num <- return (read (c:cs) :: Integer)
	135	spaces
	136	return num
	137
	138	quotedString = do
	139	c1 <- char '"'
	140	s <- many $ satisfy (\x -> x /= '"')
	141	c2 <- char '"'
	142	spaces
	143	return s
	144
	145	--
	146	-- Driver
	147	--
	148
	149	parseFountain :: String -> Either ParseError Grammar
	150	parseFountain text = parse fountain "" text

+79

-0

src/Language/Fountain/Parser.hs less more

	0	module Language.Fountain.Parser (parseFrom, formatResult) where
	1
	2	import Language.Fountain.Grammar
	3	import Language.Fountain.Constraint
	4	import Language.Fountain.Store
	5
	6
	7	data ParseState = Parsing String Store
	8	\| Failure
	9	deriving (Show, Ord, Eq)
	10
	11
	12	expectTerminal tc (Parsing (c:cs) a) = if c == tc then (Parsing cs a) else Failure
	13	expectTerminal tc Failure = Failure
	14
	15	formatResult (Parsing "" _) = "Success"
	16	formatResult (Parsing s _) = "Remaining: " ++ (show s)
	17	formatResult Failure = "Failure"
	18
	19
	20	parse :: Grammar -> ParseState -> Expr -> ParseState
	21
	22	parse g st (Seq s) = parseSeq g st s where
	23	parseSeq g st [] = st
	24	parseSeq g st (e : rest) =
	25	case parse g st e of
	26	Failure -> Failure
	27	st' -> parseSeq g st' rest
	28
	29	parse g st (Alt s) = parseAlt g st s where
	30	parseAlt g st [] = Failure
	31	parseAlt g st (e : rest) =
	32	case parse g st e of
	33	Failure -> parseAlt g st rest
	34	st' -> st'
	35
	36	parse g st (Loop l _) = parseLoop g st l where
	37	parseLoop g st e =
	38	case parse g st e of
	39	Failure -> st
	40	st' -> parseLoop g st' e
	41
	42	parse g st (Term t) = parseTerm g st t where
	43	parseTerm g st t@(T c) = expectTerminal c st
	44	parseTerm g st nt@(NT _) = parse g st (production nt g)
	45
	46	parse g st@(Parsing text store) (Constraint cstr) =
	47	case applyConstraint cstr store of
	48	Just store' ->
	49	Parsing text store'
	50	Nothing ->
	51	Failure
	52
	53	applyConstraint :: Constraint -> Store -> Maybe Store
	54	applyConstraint (UnifyConst v i) st =
	55	case fetch v st of
	56	Just value ->
	57	if value == i then Just st else Nothing
	58	Nothing ->
	59	Just $ insert v i st
	60	applyConstraint (UnifyVar v w) st =
	61	case (fetch v st, fetch w st) of
	62	(Just vValue, Just wValue) ->
	63	if vValue == wValue then Just st else Nothing
	64	(Just vValue, Nothing) ->
	65	Just $ insert w vValue st
	66	(Nothing, Just wValue) ->
	67	Just $ insert v wValue st
	68	(Nothing, Nothing) ->
	69	Just st
	70	applyConstraint (Arb v) st = Just st
	71	applyConstraint (Inc v i) st =
	72	Just $ update (\i -> Just (i + 1)) v st
	73	applyConstraint (Dec v i) st =
	74	Just $ update (\i -> Just (i - 1)) v st
	75
	76
	77	parseFrom :: Grammar -> String -> ParseState
	78	parseFrom g s = parse g (Parsing s empty) (production (startSymbol g) g)

+43

-0

src/Language/Fountain/Preprocessor.hs less more

	0	module Language.Fountain.Preprocessor where
	1
	2	import Data.List
	3
	4	import Language.Fountain.Grammar
	5	import Language.Fountain.Constraint
	6
	7
	8	preprocessGrammar :: Grammar -> Grammar
	9	preprocessGrammar (Grammar productions) =
	10	let
	11	productions' = map (\(term, expr) -> (term, preprocessExpr expr)) productions
	12	in
	13	Grammar productions'
	14
	15	preprocessExpr :: Expr -> Expr
	16	preprocessExpr (Seq exprs) = Seq (preprocessSeq exprs) where
	17	preprocessSeq [] = []
	18	preprocessSeq ((Loop expr _):rest) =
	19	let
	20	expr' = preprocessExpr expr
	21	(constraints, rest') = absorbConstraints rest
	22	in
	23	(Loop expr' constraints):(preprocessSeq rest')
	24	preprocessSeq (expr:rest) =
	25	(preprocessExpr expr):(preprocessSeq rest)
	26	preprocessExpr (Alt exprs) = Alt (map preprocessExpr exprs)
	27	preprocessExpr (Loop expr _) = error "Cannot preprocess Loop that is not in Seq"
	28	preprocessExpr other = other
	29
	30
	31	absorbConstraints :: [Expr] -> ([Constraint], [Expr])
	32	absorbConstraints exprs =
	33	let
	34	constraints' = map (extractConstraint) (takeWhile (isConstraint) exprs)
	35	exprs' = dropWhile (isConstraint) exprs
	36
	37	isConstraint (Constraint _) = True
	38	isConstraint _ = False
	39
	40	extractConstraint (Constraint c) = c
	41	in
	42	(constraints', exprs')

+17

-0

src/Language/Fountain/Store.hs less more

	0	module Language.Fountain.Store where
	1
	2	import qualified Data.Map as Map
	3
	4	import Language.Fountain.Constraint
	5
	6
	7	data Store = Store {
	8	table :: Map.Map Variable Integer,
	9	events :: [String]
	10	} deriving (Show, Ord, Eq)
	11
	12
	13	empty = Store{ table=Map.empty, events=[] }
	14	fetch k st = Map.lookup k (table st)
	15	insert k v st = st{ table=Map.insert k v (table st), events=("insert":events st) }
	16	update f k st = st{ table=Map.update f k (table st), events=("update":events st) }

+67

-0

src/Main.hs less more

	0	module Main where
	1
	2	import System.Environment
	3	import System.Exit
	4	import System.IO
	5
	6	import qualified Language.Fountain.Loader as Loader
	7	import qualified Language.Fountain.Parser as Parser
	8	import qualified Language.Fountain.Generator as Generator
	9	import qualified Language.Fountain.Preprocessor as Preprocessor
	10
	11
	12	data Flags = Flags {
	13	dumpState :: Bool
	14	} deriving (Show, Ord, Eq)
	15
	16	defaultFlags = Flags{ dumpState = False }
	17
	18	parseFlags flags ("--dump-state":rest) =
	19	parseFlags flags{ dumpState = True } rest
	20	parseFlags flags other = (flags, other)
	21
	22
	23	main = do
	24	args <- getArgs
	25	let (flags, args') = parseFlags defaultFlags args
	26	case args' of
	27	["load", grammarFileName] -> do
	28	grammar <- loadSource grammarFileName
	29	putStrLn $ show grammar
	30	["preprocess", grammarFileName] -> do
	31	grammar <- loadSource grammarFileName
	32	let grammar' = Preprocessor.preprocessGrammar grammar
	33	putStrLn $ show grammar'
	34	["parse", grammarFileName, textFileName] -> do
	35	grammar <- loadSource grammarFileName
	36	text <- loadText textFileName
	37	let result = Parser.parseFrom grammar text
	38	putStrLn $ if (dumpState flags) then show result else Parser.formatResult result
	39	["generate", grammarFileName] -> do
	40	grammar <- loadSource grammarFileName
	41	let grammar' = Preprocessor.preprocessGrammar grammar
	42	let result = Generator.generateFrom grammar'
	43	putStrLn $ if (dumpState flags) then show result else Generator.formatResult result
	44	_ -> do
	45	abortWith "Usage: fountain {flags} (load\|preprocess\|parse\|generate) <input-filename> [<input-text>]"
	46
	47
	48	loadSource fileName = do
	49	handle <- openFile fileName ReadMode
	50	-- hSetEncoding handle utf8
	51	text <- hGetContents handle
	52	case Loader.parseFountain text of
	53	Right g -> do
	54	return g
	55	Left error ->
	56	abortWith $ show error
	57
	58	loadText fileName = do
	59	handle <- openFile fileName ReadMode
	60	-- hSetEncoding handle utf8
	61	text <- hGetContents handle
	62	return text
	63
	64	abortWith msg = do
	65	hPutStrLn stderr msg
	66	exitWith $ ExitFailure 1

+4

-0

test.sh less more

	0	#!/bin/sh -e
	1
	2	falderal doc/Definition-of-Fountain.md
	3