gdritter repos apicius / cc35180
Lots of little improvements to running harness: - Added Util module with a Text-based Show equivalent - Switched existing output modes (reverse-tree, dot) to produce Text instead of String - Added basic system and converted main to use errors ScriptT system Getty Ritter 7 years ago
4 changed file(s) with 195 addition(s) and 132 deletion(s). Collapse all Expand all
+6
-2
apicius.cabal less more
1616 main-is: Main.hs
1717 other-modules: Lexer,
1818 Parser,
19 AST
19 AST,
20 BuildTree,
21 Util
2022 build-tools: happy, alex
2123 default-extensions: OverloadedStrings,
2224 ScopedTypeVariables
2325 ghc-options: -Wall
2426 build-depends: base >=4.7 && <4.9,
2527 text,
26 array
28 text-format,
29 array,
30 errors
2731 default-language: Haskell2010
+130
-0
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 showTree :: Recipe -> Text
126 showTree = prettyGraph . buildReverseGraph . getChunks
127
128 showDotGraph :: Recipe -> Text
129 showDotGraph r@(Recipe name _) =
130 dotGraph name . buildReverseGraph . getChunks $ r
+40
-130
src/Main.hs less more
1 {-# LANGUAGE ParallelListComp #-}
2
31 module Main where
42
5 import Data.List (intercalate)
6 import qualified Data.Text as T
3 import Control.Error
74 import Data.Text (Text)
5 import qualified Data.Text.IO as T
6 import System.Environment (getArgs)
7 import System.IO ( IOMode(WriteMode)
8 , hClose
9 , openFile
10 , stdout
11 )
812
9 import AST
13 import AST (Recipe)
14 import BuildTree (showDotGraph, showTree)
1015 import Parser (parseFile)
1116
17 usage :: String
18 usage =
19 unlines ("\n\nCOMMANDS:" : [ " " ++ r | (r, _) <- renderers ])
20
21 renderers :: [(String, Recipe -> Text)]
22 renderers =
23 [ ("dot", showDotGraph)
24 , ("reverse-tree", showTree)
25 ]
26
1227 main :: IO ()
13 main = do
14 cs <- getContents
15 case parseFile "[stdin]" cs of
16 Left err -> putStrLn err
17 Right recipes ->
18 putStrLn (unlines (map showRecipeGraph recipes))
19
20 -- An 'ActionChunk' represents a set of actions in between two join
21 -- points. This is 'reversed' from what we'd expect: the 'name' is
22 -- actually the name of the join point at the end of a sequence of
23 -- actions, or the string DONE, while the 'prev' is the name of the
24 -- join point that came at the beginning, or the ingredients list
25 -- that started the rule. The actions also will appear in reverse
26 -- order.
27
28 -- Maybe an explanation is in order: this rule
29 -- ingredients -> a -> $x -> b -> c -> $y;
30 -- will produce two ActionChunks:
31 -- ActionChunk $y [c, b] (Right $x)
32 -- and
33 -- ActionChunk $x [a] (Left ingredients)
34 data ActionChunk = ActionChunk
35 { acName :: Text
36 , acRules :: [Text]
37 , acPrev :: Either IngredientList Text
38 } deriving (Eq, Show)
39
40 -- This is the function that actually splits apart the action into
41 -- ActionChunks. It's grosser than I'd hoped, but it's mostly a lot
42 -- of fiddly but straightforward traversing.
43 splitApart :: Either IngredientList Text -> [Action] -> [ActionChunk]
44 splitApart i = toChunk [] . reverse
45 where toChunk cs (Join t:xs) =
46 gather t xs [] cs
47 toChunk cs (Action "DONE" _:xs) =
48 gather "DONE" xs [] cs
49 toChunk cs (Done:xs) =
50 gather "DONE" xs [] cs
51 toChunk _ (Action _ _:_) =
52 error "expected chunk to end with a join or DONE"
53 toChunk cs [] = cs
54 gather n xs@(Join t:_) as cs =
55 toChunk (ActionChunk n (reverse as) (Right t) : cs) xs
56 gather n (Action t _:xs) as cs =
57 gather n xs (t:as) cs
58 gather _ (Done:_) _ _ =
59 error "unsure how to handle this case"
60 gather n [] as cs =
61 ActionChunk n (reverse as) i : cs
62
63 -- Here we take a recipe and pull all the ActionChunks into a single
64 -- list.
65 getChunks :: Recipe -> [ActionChunk]
66 getChunks Recipe { rRecipe = st } =
67 mconcat (map getActions st)
68 where getActions (Step (InpJoin t) as) = splitApart (Right t) as
69 getActions (Step (InpIngredients is) as) = splitApart (Left is) as
70
71 -- The ReverseGraph is a tree rooted at the DONE node. The 'children'
72 -- are actually the steps leading up to a given node. Only childless
73 -- nodes should have an IngredientList associated with them, but we
74 -- don't encode this invariant in the type.
75 data ReverseGraph = ReverseGraph
76 { rStep :: Either IngredientList Text
77 , rPrevs :: [ReverseGraph]
78 } deriving (Eq, Show)
79
80 -- Take a list of ActionChunks and stitch them back together so that
81 -- we can build a ReverseGraph of them. Again, fiddly but straightforward
82 -- traversing of the data structures.
83 buildReverseGraph :: [ActionChunk] -> ReverseGraph
84 buildReverseGraph as = ReverseGraph (Right "DONE")
85 (concat (map buildFrom (findChunks "DONE")))
86 where findChunks n = [ chunk | chunk <- as, acName chunk == n ]
87 buildFrom (ActionChunk _ rs p) = go rs p
88 go [] (Right p) = concat $ map buildFrom (findChunks p)
89 go [] (Left i) = [ReverseGraph (Left i) []]
90 go (r:rs) p = [ReverseGraph (Right r) (go rs p)]
91
92 -- Prettily convert a ReverseGraph to a readable tree. This will give
93 -- us a recipe tree in reverse order, starting with the DONE, and
94 -- gradually going back to the ingredients.
95 prettyGraph :: ReverseGraph -> String
96 prettyGraph = go 0
97 where go n (ReverseGraph t rs) =
98 indent n ++ stepName t ++ "\n" ++ concat (map (go (n+2)) rs)
99 indent n = replicate n ' '
100
101 stepName :: Either IngredientList Text -> String
102 stepName (Right t) = T.unpack t
103 stepName (Left (IngredientList is)) =
104 intercalate "; " [ ingName i | i <- is ]
105 where ingName (Ingredient (Just amt) name) =
106 T.unpack amt ++ " " ++ T.unpack name
107 ingName (Ingredient Nothing name) =
108 T.unpack name
109
110 stepMeta :: Either IngredientList Text -> String
111 stepMeta (Right t) = " [label=\"" ++ T.unpack t ++ "\",color=red]"
112 stepMeta (Left (IngredientList is)) =
113 " [label=\"" ++ intercalate "; " [ ingName i | i <- is ] ++ "\"]"
114 where ingName (Ingredient (Just amt) name) =
115 T.unpack amt ++ " " ++ T.unpack name
116 ingName (Ingredient Nothing name) =
117 T.unpack name
118
119 dotGraph :: Text -> ReverseGraph -> String
120 dotGraph rname gr = ("digraph \"" ++ T.unpack rname ++ "\" {\n") ++ unlines (go "n" 0 gr) ++ "\n}"
121 where go :: String -> Int -> ReverseGraph -> [String]
122 go parent n (ReverseGraph t rs) =
123 let name = parent ++ "_" ++ show n
124 children = [ (i, name ++ "_" ++ show i, r)
125 | i <- [0..]
126 | r <- rs
127 ]
128 in [ " " ++ name ++ stepMeta t ] ++
129 [ " " ++ cname ++ " -> " ++ name ++ ";"
130 | (_, cname, _) <- children
131 ] ++
132 concat [ go name i r
133 | (i, _, r) <- children
134 ]
135
136 showRecipeGraph :: Recipe -> String
137 showRecipeGraph r@(Recipe name _) = dotGraph name . buildReverseGraph . getChunks $ r
28 main = runScript $ do
29 as <- scriptIO getArgs
30 (file, render, contents, output) <- case as of
31 [x] -> do
32 r <- lookup x renderers ?? ("Unable to find renderer " ++ x)
33 cs <- scriptIO getContents
34 return ("[stdin]", r, cs, stdout)
35 [x,f] -> do
36 r <- lookup x renderers ?? ("Unable to find renderer " ++ x)
37 cs <- scriptIO $ readFile f
38 return (f, r, cs, stdout)
39 [x,f,o] -> do
40 r <- lookup x renderers ?? ("Unable to find renderer " ++ x)
41 cs <- scriptIO $ readFile f
42 file <- scriptIO $ openFile o WriteMode
43 return (f, r, cs, file)
44 _ -> throwE usage
45 ast <- hoistEither $ parseFile file contents
46 mapM_ (scriptIO . T.hPutStrLn output . render) ast
47 scriptIO $ hClose output
+19
-0
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