Commit 859ea5c8f1ea00294c15c193d91698e9fd6e774f - apicius

+72

-0

Apicius/AST.hs less more

	1	module Apicius.AST where
	2
	3	import Data.Monoid ((<>))
	4	import Data.Text (Text)
	5	import Apicius.Util
	6
	7	data Recipe = Recipe
	8	{ rName :: Text
	9	, rRecipe :: [Step]
	10	} deriving (Eq, Show)
	11
	12	instance TShow Recipe where
	13	text (Recipe name steps) =
	14	"Recipe { rName = " <>
	15	text name <>
	16	", rRecipe = " <>
	17	text steps <>
	18	" }"
	19
	20	data Step = Step
	21	{ sInputs :: Input
	22	, sActions :: [Action]
	23	} deriving (Eq, Show)
	24
	25	instance TShow Step where
	26	text (Step inp acts) =
	27	"Step { sInputs = " <>
	28	text inp <>
	29	", sActions = " <>
	30	text acts <>
	31	" }"
	32
	33	data Input
	34	= InpIngredients IngredientList
	35	\| InpJoin Text
	36	deriving (Eq, Show)
	37
	38	instance TShow Input where
	39	text (InpJoin ts) = text ts
	40	text (InpIngredients is) = text is
	41
	42	data IngredientList = IngredientList
	43	{ fromIngredientList :: [Ingredient]
	44	} deriving (Eq, Show)
	45
	46	instance TShow IngredientList where
	47	text (IngredientList is) =
	48	"IngredientList " <> text is
	49
	50	data Ingredient = Ingredient
	51	{ iAmount :: Maybe Text
	52	, iType :: Text
	53	} deriving (Eq, Show)
	54
	55	instance TShow Ingredient where
	56	text (Ingredient i t) =
	57	"Ingredient { iAmount = " <>
	58	text i <>
	59	", iType = " <>
	60	text t <>
	61	" }"
	62
	63	data Action
	64	= Action Text (Maybe IngredientList)
	65	\| Join Text
	66	\| Done
	67	deriving (Eq, Show)
	68
	69	instance TShow Action where
	70	text (Action t i) = "Action " <> text t <> " " <> text i
	71	text (Join t) = "Join " <> text t
	72	text Done = "Done"

+18

-0

Apicius/Language.hs less more

	1	module Apicius.Language ( Recipe(..)
	2	, Step(..)
	3	, Input(..)
	4	, IngredientList(..)
	5	, Ingredient(..)
	6	, Action(..)
	7	, parseFile
	8	, showAst
	9	) where
	10
	11	import Data.Text (Text)
	12
	13	import Apicius.AST
	14	import Apicius.Parser
	15	import Apicius.Util (text)
	16
	17	showAst :: Recipe -> Text
	18	showAst = text

+104

-0

Apicius/Lexer.x less more

	1	{
	2	{-# OPTIONS -w #-}
	3	{-# LANGUAGE OverloadedStrings #-}
	4
	5	module Apicius.Lexer where
	6
	7	import Control.Monad (liftM)
	8	import Data.Text (Text)
	9	import qualified Data.Text as T
	10
	11	import Prelude hiding (lex)
	12	}
	13
	14	%wrapper "monadUserState"
	15
	16	$special = [ \{ \} \[ \] \; \, \+ \& \- \$ ]
	17	$idchar = $printable # $special
	18
	19	tokens :-
	20	$white+ ;
	21	"#".* ;
	22
	23	DONE { lex' TkDone }
	24
	25	\{ { lex' TkLCurl }
	26	\} { lex' TkRCurl }
	27	\[ { lex' TkLBrac }
	28	\] { lex' TkRBrac }
	29	\; { lex' TkSemi }
	30	\+ { lex' TkPlus }
	31	\& { lex' TkAnd }
	32
	33	\-\> { lex' TkArrow }
	34
	35	$idchar + { lex (TkText . T.strip) }
	36
	37	\$ $idchar + { lex (TkJoin . T.strip) }
	38
	39	{
	40	data Token = Token AlexPosn TkType deriving (Eq, Show)
	41
	42	data TkType
	43	= TkLCurl
	44	\| TkRCurl
	45	\| TkLBrac
	46	\| TkRBrac
	47	\| TkArrow
	48	\| TkAnd
	49	\| TkSemi
	50	\| TkDone
	51	\| TkPlus
	52	\| TkText Text
	53	\| TkJoin Text
	54	\| TkEOF
	55	deriving (Eq, Show)
	56
	57	data AlexUserState = AlexUserState
	58	{ filePath :: FilePath
	59	} deriving (Eq, Show)
	60
	61	alexInitUserState :: AlexUserState
	62	alexInitUserState = AlexUserState "<unknown>"
	63
	64	getFilePath :: Alex FilePath
	65	getFilePath = liftM filePath alexGetUserState
	66
	67	setFilePath :: FilePath -> Alex ()
	68	setFilePath = alexSetUserState . AlexUserState
	69
	70	alexMonadScan' :: Alex Token
	71	alexMonadScan' = do
	72	inp <- alexGetInput
	73	sc <- alexGetStartCode
	74	case alexScan inp sc of
	75	AlexEOF -> alexEOF
	76	AlexError (p, _, _, s) ->
	77	alexError' p ("lexical error at character '" ++ take 1 s ++ "'")
	78	AlexSkip inp' len -> do
	79	alexSetInput inp'
	80	alexMonadScan'
	81	AlexToken inp' len action -> do
	82	alexSetInput inp'
	83	action (ignorePendingBytes inp) len
	84
	85	alexError' :: AlexPosn -> String -> Alex a
	86	alexError' (AlexPn _ l c) msg = do
	87	fp <- getFilePath
	88	alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
	89
	90	alexEOF :: Alex Token
	91	alexEOF = do
	92	(p,_,_,_) <- alexGetInput
	93	return (Token p TkEOF)
	94
	95
	96	lex :: (Text -> TkType) -> AlexAction Token
	97	lex f = \(p,_,_,s) i -> return (Token p (f (T.pack (take i s))))
	98
	99	lex' :: TkType -> AlexAction Token
	100	lex' = lex . const
	101
	102	runAlex' :: Alex a -> FilePath -> String -> Either String a
	103	runAlex' mote fp input = runAlex input (setFilePath fp >> mote)
	104	}

+84

-0

Apicius/Parser.y less more

	1	{
	2	{-# LANGUAGE OverloadedStrings #-}
	3
	4	module Apicius.Parser where
	5
	6	import Apicius.AST
	7	import Apicius.Lexer
	8
	9	}
	10
	11	%name parse
	12	%tokentype { Token }
	13	%monad { Alex }
	14	%lexer { lexwrap } { Token _ TkEOF }
	15	%error { happyError }
	16
	17	%token
	18	'{' { Token _ TkLCurl }
	19	'}' { Token _ TkRCurl }
	20	'[' { Token _ TkLBrac }
	21	']' { Token _ TkRBrac }
	22	';' { Token _ TkSemi }
	23	'+' { Token _ TkPlus }
	24	'&' { Token _ TkAnd }
	25
	26	'->' { Token _ TkArrow }
	27	done { Token _ TkDone }
	28
	29	text { Token _ (TkText $$) }
	30	join { Token _ (TkJoin $$) }
	31
	32	%%
	33
	34	file
	35	: recipe file { $1 : $2 }
	36	\| { [] }
	37
	38	recipe
	39	: text '{' steps '}' { Recipe $1 $3 }
	40
	41	steps
	42	: step ';' steps { $1 : $3 }
	43	\| { [] }
	44
	45	step
	46	: input '->' actions { Step $1 $3 }
	47
	48	input
	49	: ilist { InpIngredients $1 }
	50	\| join { InpJoin $1 }
	51
	52	ilist
	53	: ingredients { IngredientList $1 }
	54
	55	ingredients
	56	: ingredient '+' ingredients { $1 : $3 }
	57	\| ingredient { [$1] }
	58
	59	ingredient
	60	: '[' text ']' text { Ingredient (Just $2) $4 }
	61	\| text { Ingredient Nothing $1 }
	62
	63	actions
	64	: action '->' actions { $1 : $3 }
	65	\| action { [$1] }
	66
	67	action
	68	: text { Action $1 Nothing }
	69	\| text '&' ilist { Action $1 (Just $3) }
	70	\| join { Join $1 }
	71	\| done { Done }
	72
	73	{
	74
	75	lexwrap :: (Token -> Alex a) -> Alex a
	76	lexwrap = (alexMonadScan' >>=)
	77
	78	happyError :: Token -> Alex a
	79	happyError (Token p t) =
	80	alexError' p ("parse error at token " ++ show t)
	81
	82	parseFile :: FilePath -> String -> Either String [Recipe]
	83	parseFile = runAlex' parse
	84	}

+38

-0

Apicius/Render/Dot.hs less more

	1	{-# LANGUAGE ParallelListComp #-}
	2
	3	module Apicius.Render.Dot (showDotGraph) where
	4
	5	import Data.Monoid ((<>))
	6	import Data.Text (Text)
	7	import qualified Data.Text as T
	8
	9	import Apicius.Language
	10	import Apicius.ReverseTree
	11	import Apicius.Util
	12
	13	showDotGraph :: Recipe -> Text
	14	showDotGraph r@(Recipe name _) =
	15	dotGraph name . buildReverseGraph . getChunks $ r
	16
	17	dotGraph :: Text -> ReverseGraph -> Text
	18	dotGraph rname gr =
	19	("digraph \"" <> rname <> "\" {\n") <> T.unlines (go "n" 0 gr) <> "\n}"
	20	where go :: Text -> Int -> ReverseGraph -> [Text]
	21	go parent n (ReverseGraph t rs) =
	22	let name = parent <> "_" <> text n
	23	children = [ (i, name <> "_" <> text i, r)
	24	\| i <- [0..]
	25	\| r <- rs
	26	]
	27	in [ " " <> name <> stepMeta t ] ++
	28	[ " " <> cname <> " -> " <> name <> ";"
	29	\| (_, cname, _) <- children
	30	] ++
	31	concat [ go name i r
	32	\| (i, _, r) <- children
	33	]
	34
	35	stepMeta :: Either IngredientList Text -> Text
	36	stepMeta (Right t) = " [label=\"" <> t <> "\",color=red]"
	37	stepMeta (Left (IngredientList is)) =
	38	" [label=\"" <> T.intercalate "; " [ ingName i \| i <- is ] <> "\"]"

+105

-0

Apicius/ReverseTree.hs less more

	1	{-# LANGUAGE ParallelListComp #-}
	2
	3	module Apicius.ReverseTree where
	4
	5	import Data.Monoid ((<>))
	6	import qualified Data.Text as T
	7	import Data.Text (Text)
	8
	9	import Apicius.AST
	10
	11	-- An 'ActionChunk' represents a set of actions in between two join
	12	-- points. This is 'reversed' from what we'd expect: the 'name' is
	13	-- actually the name of the join point at the end of a sequence of
	14	-- actions, or the string DONE, while the 'prev' is the name of the
	15	-- join point that came at the beginning, or the ingredients list
	16	-- that started the rule. The actions also will appear in reverse
	17	-- order.
	18
	19	-- Maybe an explanation is in order: this rule
	20	-- ingredients -> a -> $x -> b -> c -> $y;
	21	-- will produce two ActionChunks:
	22	-- ActionChunk $y [c, b] (Right $x)
	23	-- and
	24	-- ActionChunk $x [a] (Left ingredients)
	25	data ActionChunk = ActionChunk
	26	{ acName :: Text
	27	, acRules :: [Text]
	28	, acPrev :: Either IngredientList Text
	29	} deriving (Eq, Show)
	30
	31	-- This is the function that actually splits apart the action into
	32	-- ActionChunks. It's grosser than I'd hoped, but it's mostly a lot
	33	-- of fiddly but straightforward traversing.
	34	splitApart :: Either IngredientList Text -> [Action] -> [ActionChunk]
	35	splitApart i = toChunk [] . reverse
	36	where toChunk cs (Join t:xs) =
	37	gather t xs [] cs
	38	toChunk cs (Action "DONE" _:xs) =
	39	gather "DONE" xs [] cs
	40	toChunk cs (Done:xs) =
	41	gather "DONE" xs [] cs
	42	toChunk _ (Action _ _:_) =
	43	error "expected chunk to end with a join or DONE"
	44	toChunk cs [] = cs
	45	gather n xs@(Join t:_) as cs =
	46	toChunk (ActionChunk n (reverse as) (Right t) : cs) xs
	47	gather n (Action t _:xs) as cs =
	48	gather n xs (t:as) cs
	49	gather _ (Done:_) _ _ =
	50	error "unsure how to handle this case"
	51	gather n [] as cs =
	52	ActionChunk n (reverse as) i : cs
	53
	54	-- Here we take a recipe and pull all the ActionChunks into a single
	55	-- list.
	56	getChunks :: Recipe -> [ActionChunk]
	57	getChunks Recipe { rRecipe = st } =
	58	mconcat (map getActions st)
	59	where getActions (Step (InpJoin t) as) = splitApart (Right t) as
	60	getActions (Step (InpIngredients is) as) = splitApart (Left is) as
	61
	62	-- The ReverseGraph is a tree rooted at the DONE node. The 'children'
	63	-- are actually the steps leading up to a given node. Only childless
	64	-- nodes should have an IngredientList associated with them, but we
	65	-- don't encode this invariant in the type.
	66	data ReverseGraph = ReverseGraph
	67	{ rStep :: Either IngredientList Text
	68	, rPrevs :: [ReverseGraph]
	69	} deriving (Eq, Show)
	70
	71	-- Take a list of ActionChunks and stitch them back together so that
	72	-- we can build a ReverseGraph of them. Again, fiddly but straightforward
	73	-- traversing of the data structures.
	74	buildReverseGraph :: [ActionChunk] -> ReverseGraph
	75	buildReverseGraph as = ReverseGraph (Right "DONE")
	76	(concat (map buildFrom (findChunks "DONE")))
	77	where findChunks n = [ chunk \| chunk <- as, acName chunk == n ]
	78	buildFrom (ActionChunk _ rs p) = go rs p
	79	go [] (Right p) = concat $ map buildFrom (findChunks p)
	80	go [] (Left i) = [ReverseGraph (Left i) []]
	81	go (r:rs) p = [ReverseGraph (Right r) (go rs p)]
	82
	83	-- Prettily convert a ReverseGraph to a readable tree. This will give
	84	-- us a recipe tree in reverse order, starting with the DONE, and
	85	-- gradually going back to the ingredients.
	86	prettyGraph :: ReverseGraph -> Text
	87	prettyGraph = go 0
	88	where go n (ReverseGraph t rs) =
	89	indent n <> stepName t <> "\n" <> T.concat (map (go (n+2)) rs)
	90	indent n = T.replicate n " "
	91
	92	stepName :: Either IngredientList Text -> Text
	93	stepName (Right t) = t
	94	stepName (Left (IngredientList is)) =
	95	T.intercalate "; " [ ingName i \| i <- is ]
	96
	97	ingName :: Ingredient -> Text
	98	ingName (Ingredient (Just amt) name) = amt <> " " <> name
	99	ingName (Ingredient Nothing name) = name
	100
	101	showFragments :: Recipe -> Text
	102	showFragments = T.pack . show . getChunks
	103
	104	showReverseTree :: Recipe -> Text
	105	showReverseTree = prettyGraph . buildReverseGraph . getChunks

+26

-0

Apicius/Util.hs less more

	1	{-# LANGUAGE DefaultSignatures #-}
	2
	3	module Apicius.Util where
	4
	5	import Data.Monoid ((<>))
	6	import Data.Text.Buildable (Buildable(..))
	7	import Data.Text (Text)
	8	import qualified Data.Text as T
	9	import Data.Text.Lazy (toStrict)
	10	import Data.Text.Lazy.Builder (toLazyText)
	11
	12	class TShow s where
	13	text :: s -> Text
	14
	15	default text :: Buildable s => s -> Text
	16	text = toStrict . toLazyText . build
	17
	18	instance TShow Int where
	19	instance TShow Text where
	20
	21	instance TShow a => TShow [a] where
	22	text xs = "[" <> T.intercalate ", " (map text xs) <> "]"
	23
	24	instance TShow a => TShow (Maybe a) where
	25	text Nothing = "Nothing"
	26	text (Just a) = "Just " <> text a

+21

-10

apicius.cabal less more

11	11	build-type: Simple
12	12	cabal-version: >= 1.12
13	13
14		executable apicius
15		hs-source-dirs: src
16		main-is: Main.hs
17		other-modules: Lexer,
18		Parser,
19		AST,
20		BuildTree,
21		Util
	14	library
	15	exposed-modules: Apicius.Language,
	16	Apicius.ReverseTree,
	17	Apicius.Render.Dot
	18	other-modules: Apicius.AST,
	19	Apicius.Lexer,
	20	Apicius.Parser,
	21	Apicius.Util
	22	build-depends: base >=4.7 && <4.9,
	23	text,
	24	text-format,
	25	array
22	26	build-tools: happy, alex
23	27	default-extensions: OverloadedStrings,
24	28	ScopedTypeVariables
25	29	ghc-options: -Wall
	30	default-language: Haskell2010
	31
	32	executable apicius
	33	hs-source-dirs: src
	34	main-is: Main.hs
	35	default-extensions: OverloadedStrings,
	36	ScopedTypeVariables
	37	ghc-options: -Wall
26	38	build-depends: base >=4.7 && <4.9,
	39	apicius,
27	40	text,
28		text-format,
29		array,
30	41	errors
31	42	default-language: Haskell2010

+0

-73

~~src/AST.hs~~ less more

1		module AST where
2
3		import Data.Monoid ((<>))
4		import Data.Text (Text)
5		import Util
6
7		data Recipe = Recipe
8		{ rName :: Text
9		, rRecipe :: [Step]
10		} deriving (Eq, Show)
11
12		instance TShow Recipe where
13		text (Recipe name steps) =
14		"Recipe { rName = " <>
15		text name <>
16		", rRecipe = " <>
17		text steps <>
18		" }"
19
20		data Step = Step
21		{ sInputs :: Input
22		, sActions :: [Action]
23		} deriving (Eq, Show)
24
25		instance TShow Step where
26		text (Step inp acts) =
27		"Step { sInputs = " <>
28		text inp <>
29		", sActions = " <>
30		text acts <>
31		" }"
32
33		data Input
34		= InpIngredients IngredientList
35		\| InpJoin Text
36		deriving (Eq, Show)
37
38		instance TShow Input where
39		text (InpJoin ts) = text ts
40		text (InpIngredients is) = text is
41
42		data IngredientList = IngredientList
43		{ fromIngredientList :: [Ingredient]
44		} deriving (Eq, Show)
45
46		instance TShow IngredientList where
47		text (IngredientList is) =
48		"IngredientList " <> text is
49
50		data Ingredient = Ingredient
51		{ iAmount :: Maybe Text
52		, iType :: Text
53		} deriving (Eq, Show)
54
55		instance TShow Ingredient where
56		text (Ingredient i t) =
57		"Ingredient { iAmount = " <>
58		text i <>
59		", iType = " <>
60		text t <>
61		" }"
62
63		data Action
64		= Action Text (Maybe IngredientList)
65		\| Join Text
66		\| Done
67		deriving (Eq, Show)
68
69		instance TShow Action where
70		text (Action t i) = "Action " <> text t <> " " <> text i
71		text (Join t) = "Join " <> text t
72		text Done = "Done"
73

+0

-133

~~src/BuildTree.hs~~ less more

1		{-# LANGUAGE ParallelListComp #-}
2
3		module BuildTree where
4
5		import Data.Monoid ((<>))
6		import qualified Data.Text as T
7		import Data.Text (Text)
8
9		import AST
10		import Util
11
12		-- An 'ActionChunk' represents a set of actions in between two join
13		-- points. This is 'reversed' from what we'd expect: the 'name' is
14		-- actually the name of the join point at the end of a sequence of
15		-- actions, or the string DONE, while the 'prev' is the name of the
16		-- join point that came at the beginning, or the ingredients list
17		-- that started the rule. The actions also will appear in reverse
18		-- order.
19
20		-- Maybe an explanation is in order: this rule
21		-- ingredients -> a -> $x -> b -> c -> $y;
22		-- will produce two ActionChunks:
23		-- ActionChunk $y [c, b] (Right $x)
24		-- and
25		-- ActionChunk $x [a] (Left ingredients)
26		data ActionChunk = ActionChunk
27		{ acName :: Text
28		, acRules :: [Text]
29		, acPrev :: Either IngredientList Text
30		} deriving (Eq, Show)
31
32		-- This is the function that actually splits apart the action into
33		-- ActionChunks. It's grosser than I'd hoped, but it's mostly a lot
34		-- of fiddly but straightforward traversing.
35		splitApart :: Either IngredientList Text -> [Action] -> [ActionChunk]
36		splitApart i = toChunk [] . reverse
37		where toChunk cs (Join t:xs) =
38		gather t xs [] cs
39		toChunk cs (Action "DONE" _:xs) =
40		gather "DONE" xs [] cs
41		toChunk cs (Done:xs) =
42		gather "DONE" xs [] cs
43		toChunk _ (Action _ _:_) =
44		error "expected chunk to end with a join or DONE"
45		toChunk cs [] = cs
46		gather n xs@(Join t:_) as cs =
47		toChunk (ActionChunk n (reverse as) (Right t) : cs) xs
48		gather n (Action t _:xs) as cs =
49		gather n xs (t:as) cs
50		gather _ (Done:_) _ _ =
51		error "unsure how to handle this case"
52		gather n [] as cs =
53		ActionChunk n (reverse as) i : cs
54
55		-- Here we take a recipe and pull all the ActionChunks into a single
56		-- list.
57		getChunks :: Recipe -> [ActionChunk]
58		getChunks Recipe { rRecipe = st } =
59		mconcat (map getActions st)
60		where getActions (Step (InpJoin t) as) = splitApart (Right t) as
61		getActions (Step (InpIngredients is) as) = splitApart (Left is) as
62
63		-- The ReverseGraph is a tree rooted at the DONE node. The 'children'
64		-- are actually the steps leading up to a given node. Only childless
65		-- nodes should have an IngredientList associated with them, but we
66		-- don't encode this invariant in the type.
67		data ReverseGraph = ReverseGraph
68		{ rStep :: Either IngredientList Text
69		, rPrevs :: [ReverseGraph]
70		} deriving (Eq, Show)
71
72		-- Take a list of ActionChunks and stitch them back together so that
73		-- we can build a ReverseGraph of them. Again, fiddly but straightforward
74		-- traversing of the data structures.
75		buildReverseGraph :: [ActionChunk] -> ReverseGraph
76		buildReverseGraph as = ReverseGraph (Right "DONE")
77		(concat (map buildFrom (findChunks "DONE")))
78		where findChunks n = [ chunk \| chunk <- as, acName chunk == n ]
79		buildFrom (ActionChunk _ rs p) = go rs p
80		go [] (Right p) = concat $ map buildFrom (findChunks p)
81		go [] (Left i) = [ReverseGraph (Left i) []]
82		go (r:rs) p = [ReverseGraph (Right r) (go rs p)]
83
84		-- Prettily convert a ReverseGraph to a readable tree. This will give
85		-- us a recipe tree in reverse order, starting with the DONE, and
86		-- gradually going back to the ingredients.
87		prettyGraph :: ReverseGraph -> Text
88		prettyGraph = go 0
89		where go n (ReverseGraph t rs) =
90		indent n <> stepName t <> "\n" <> T.concat (map (go (n+2)) rs)
91		indent n = T.replicate n " "
92
93		stepName :: Either IngredientList Text -> Text
94		stepName (Right t) = t
95		stepName (Left (IngredientList is)) =
96		T.intercalate "; " [ ingName i \| i <- is ]
97
98		ingName :: Ingredient -> Text
99		ingName (Ingredient (Just amt) name) = amt <> " " <> name
100		ingName (Ingredient Nothing name) = name
101
102		stepMeta :: Either IngredientList Text -> Text
103		stepMeta (Right t) = " [label=\"" <> t <> "\",color=red]"
104		stepMeta (Left (IngredientList is)) =
105		" [label=\"" <> T.intercalate "; " [ ingName i \| i <- is ] <> "\"]"
106
107		dotGraph :: Text -> ReverseGraph -> Text
108		dotGraph rname gr =
109		("digraph \"" <> rname <> "\" {\n") <> T.unlines (go "n" 0 gr) <> "\n}"
110		where go :: Text -> Int -> ReverseGraph -> [Text]
111		go parent n (ReverseGraph t rs) =
112		let name = parent <> "_" <> text n
113		children = [ (i, name <> "_" <> text i, r)
114		\| i <- [0..]
115		\| r <- rs
116		]
117		in [ " " <> name <> stepMeta t ] ++
118		[ " " <> cname <> " -> " <> name <> ";"
119		\| (_, cname, _) <- children
120		] ++
121		concat [ go name i r
122		\| (i, _, r) <- children
123		]
124
125		showFragments :: Recipe -> Text
126		showFragments = T.pack . show . getChunks
127
128		showTree :: Recipe -> Text
129		showTree = prettyGraph . buildReverseGraph . getChunks
130
131		showDotGraph :: Recipe -> Text
132		showDotGraph r@(Recipe name _) =
133		dotGraph name . buildReverseGraph . getChunks $ r

+0

-110

~~src/Lexer.x~~ less more

1		{
2		{-# OPTIONS -w #-}
3		{-# LANGUAGE OverloadedStrings #-}
4
5		module Lexer where
6
7		import Control.Monad (liftM)
8		import Data.Text (Text)
9		import qualified Data.Text as T
10
11		import Prelude hiding (lex)
12		}
13
14		%wrapper "monadUserState"
15
16		$special = [ \{ \} \[ \] \; \, \+ \& \- \$ ]
17		$idchar = $printable # $special
18
19		tokens :-
20		$white+ ;
21		"#".* ;
22
23		DONE { lex' TkDone }
24
25		\{ { lex' TkLCurl }
26		\} { lex' TkRCurl }
27		\[ { lex' TkLBrac }
28		\] { lex' TkRBrac }
29		\( { lex' TkLParn }
30		\) { lex' TkRParn }
31		\; { lex' TkSemi }
32		\, { lex' TkComma }
33		\+ { lex' TkPlus }
34		\& { lex' TkAnd }
35
36		\-\> { lex' TkArrow }
37
38		$idchar + { lex (TkText . T.strip) }
39
40		\$ $idchar + { lex (TkJoin . T.strip) }
41
42		{
43		data Token = Token AlexPosn TkType deriving (Eq, Show)
44
45		data TkType
46		= TkLCurl
47		\| TkRCurl
48		\| TkLBrac
49		\| TkRBrac
50		\| TkLParn
51		\| TkRParn
52		\| TkArrow
53		\| TkComma
54		\| TkAnd
55		\| TkSemi
56		\| TkDone
57		\| TkPlus
58		\| TkText Text
59		\| TkJoin Text
60		\| TkEOF
61		deriving (Eq, Show)
62
63		data AlexUserState = AlexUserState
64		{ filePath :: FilePath
65		} deriving (Eq, Show)
66
67		alexInitUserState :: AlexUserState
68		alexInitUserState = AlexUserState "<unknown>"
69
70		getFilePath :: Alex FilePath
71		getFilePath = liftM filePath alexGetUserState
72
73		setFilePath :: FilePath -> Alex ()
74		setFilePath = alexSetUserState . AlexUserState
75
76		alexMonadScan' :: Alex Token
77		alexMonadScan' = do
78		inp <- alexGetInput
79		sc <- alexGetStartCode
80		case alexScan inp sc of
81		AlexEOF -> alexEOF
82		AlexError (p, _, _, s) ->
83		alexError' p ("lexical error at character '" ++ take 1 s ++ "'")
84		AlexSkip inp' len -> do
85		alexSetInput inp'
86		alexMonadScan'
87		AlexToken inp' len action -> do
88		alexSetInput inp'
89		action (ignorePendingBytes inp) len
90
91		alexError' :: AlexPosn -> String -> Alex a
92		alexError' (AlexPn _ l c) msg = do
93		fp <- getFilePath
94		alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
95
96		alexEOF :: Alex Token
97		alexEOF = do
98		(p,_,_,_) <- alexGetInput
99		return (Token p TkEOF)
100
101
102		lex :: (Text -> TkType) -> AlexAction Token
103		lex f = \(p,_,_,s) i -> return (Token p (f (T.pack (take i s))))
104
105		lex' :: TkType -> AlexAction Token
106		lex' = lex . const
107
108		runAlex' :: Alex a -> FilePath -> String -> Either String a
109		runAlex' mote fp input = runAlex input (setFilePath fp >> mote)
110		}

+7

-8

src/Main.hs less more

10	10	, stdout
11	11	)
12	12
13		import AST (Recipe)
14		import BuildTree (showFragments, showDotGraph, showTree)
15		import Parser (parseFile)
16		import Util (TShow(text))
	13	import Apicius.ReverseTree (showFragments, showReverseTree)
	14	import Apicius.Render.Dot (showDotGraph)
	15	import Apicius.Language (Recipe, parseFile, showAst)
17	16
18	17	usage :: String
19	18	usage =

21	20
22	21	renderers :: [(String, Recipe -> Text)]
23	22	renderers =
24		[ ("ast", text)
25		, ("fragments", showFragments)
26		, ("dot", showDotGraph)
27		, ("reverse-tree", showTree)
	23	[ ("ast", showAst)
	24	, ("fragments", showFragments)
	25	, ("dot", showDotGraph)
	26	, ("reverse-tree", showReverseTree)
28	27	]
29	28
30	29	main :: IO ()

+0

-87

~~src/Parser.y~~ less more

1		{
2		{-# LANGUAGE OverloadedStrings #-}
3
4		module Parser where
5
6		import AST
7		import Lexer
8
9		}
10
11		%name parse
12		%tokentype { Token }
13		%monad { Alex }
14		%lexer { lexwrap } { Token _ TkEOF }
15		%error { happyError }
16
17		%token
18		'{' { Token _ TkLCurl }
19		'}' { Token _ TkRCurl }
20		'[' { Token _ TkLBrac }
21		']' { Token _ TkRBrac }
22		'(' { Token _ TkLParn }
23		')' { Token _ TkRParn }
24		';' { Token _ TkSemi }
25		',' { Token _ TkComma }
26		'+' { Token _ TkPlus }
27		'&' { Token _ TkAnd }
28
29		'->' { Token _ TkArrow }
30		done { Token _ TkDone }
31
32		text { Token _ (TkText $$) }
33		join { Token _ (TkJoin $$) }
34
35		%%
36
37		file
38		: recipe file { $1 : $2 }
39		\| { [] }
40
41		recipe
42		: text '{' steps '}' { Recipe $1 $3 }
43
44		steps
45		: step ';' steps { $1 : $3 }
46		\| { [] }
47
48		step
49		: input '->' actions { Step $1 $3 }
50
51		input
52		: ilist { InpIngredients $1 }
53		\| join { InpJoin $1 }
54
55		ilist
56		: ingredients { IngredientList $1 }
57
58		ingredients
59		: ingredient '+' ingredients { $1 : $3 }
60		\| ingredient { [$1] }
61
62		ingredient
63		: '[' text ']' text { Ingredient (Just $2) $4 }
64		\| text { Ingredient Nothing $1 }
65
66		actions
67		: action '->' actions { $1 : $3 }
68		\| action { [$1] }
69
70		action
71		: text { Action $1 Nothing }
72		\| text '&' ilist { Action $1 (Just $3) }
73		\| join { Join $1 }
74		\| done { Done }
75
76		{
77
78		lexwrap :: (Token -> Alex a) -> Alex a
79		lexwrap = (alexMonadScan' >>=)
80
81		happyError :: Token -> Alex a
82		happyError (Token p t) =
83		alexError' p ("parse error at token " ++ show t)
84
85		parseFile :: FilePath -> String -> Either String [Recipe]
86		parseFile = runAlex' parse
87		}

+0

-26

~~src/Util.hs~~ less more

1		{-# LANGUAGE DefaultSignatures #-}
2
3		module Util where
4
5		import Data.Monoid ((<>))
6		import Data.Text.Buildable (Buildable(..))
7		import Data.Text (Text)
8		import qualified Data.Text as T
9		import Data.Text.Lazy (toStrict)
10		import Data.Text.Lazy.Builder (toLazyText)
11
12		class TShow s where
13		text :: s -> Text
14
15		default text :: Buildable s => s -> Text
16		text = toStrict . toLazyText . build
17
18		instance TShow Int where
19		instance TShow Text where
20
21		instance TShow a => TShow [a] where
22		text xs = "[" <> T.intercalate ", " (map text xs) <> "]"
23
24		instance TShow a => TShow (Maybe a) where
25		text Nothing = "Nothing"
26		text (Just a) = "Just " <> text a