gdritter repos apicius / master Apicius / ReverseTree.hs
master

Tree @master (Download .tar.gz)

ReverseTree.hs @masterraw · history · blame

{-# LANGUAGE ParallelListComp #-}

module Apicius.ReverseTree where

import           Data.Monoid ((<>))
import qualified Data.Text as T
import           Data.Text (Text)

import           Apicius.AST

-- An 'ActionChunk' represents a set of actions in between two join
-- points. This is 'reversed' from what we'd expect: the 'name' is
-- actually the name of the join point at the end of a sequence of
-- actions, or the string DONE, while the 'prev' is the name of the
-- join point that came at the beginning, or the ingredients list
-- that started the rule. The actions also will appear in reverse
-- order.

-- Maybe an explanation is in order: this rule
--   ingredients -> a -> $x -> b -> c -> $y;
-- will produce two ActionChunks:
--   ActionChunk $y [c, b] (Right $x)
-- and
--   ActionChunk $x [a] (Left ingredients)
data ActionChunk = ActionChunk
  { acName  :: Text
  , acRules :: [Text]
  , acPrev  :: Either IngredientList Text
  } deriving (Eq, Show)

-- This is the function that actually splits apart the action into
-- ActionChunks. It's grosser than I'd hoped, but it's mostly a lot
-- of fiddly but straightforward traversing.
splitApart :: Either IngredientList Text -> [Action] -> [ActionChunk]
splitApart i = toChunk [] . reverse
  where toChunk cs (Join t:xs) =
          gather t xs [] cs
        toChunk cs (Action "DONE" _:xs) =
          gather "DONE" xs [] cs
        toChunk cs (Done:xs) =
          gather "DONE" xs [] cs
        toChunk _ (Action _ _:_) =
          error "expected chunk to end with a join or DONE"
        toChunk cs [] = cs
        gather n xs@(Join t:_) as cs =
          toChunk (ActionChunk n (reverse as) (Right t) : cs) xs
        gather n (Action t _:xs) as cs =
          gather n xs (t:as) cs
        gather _ (Done:_) _ _ =
          error "unsure how to handle this case"
        gather n [] as cs =
          ActionChunk n (reverse as) i : cs

-- Here we take a recipe and pull all the ActionChunks into a single
-- list.
getChunks :: Recipe -> [ActionChunk]
getChunks Recipe { rRecipe = st } =
  mconcat (map getActions st)
  where getActions (Step (InpJoin t) as) = splitApart (Right t) as
        getActions (Step (InpIngredients is) as) = splitApart (Left is) as

-- The ReverseGraph is a tree rooted at the DONE node. The 'children'
-- are actually the steps leading up to a given node. Only childless
-- nodes should have an IngredientList associated with them, but we
-- don't encode this invariant in the type.
data ReverseGraph = ReverseGraph
  { rStep  :: Either IngredientList Text
  , rPrevs :: [ReverseGraph]
  } deriving (Eq, Show)

-- Take a list of ActionChunks and stitch them back together so that
-- we can build a ReverseGraph of them. Again, fiddly but straightforward
-- traversing of the data structures.
buildReverseGraph :: [ActionChunk] -> ReverseGraph
buildReverseGraph as = ReverseGraph (Right "DONE")
                         (concat (map buildFrom (findChunks "DONE")))
  where findChunks n = [ chunk | chunk <- as, acName chunk == n ]
        buildFrom (ActionChunk _ rs p) = go rs p
        go [] (Right p) = concat $ map buildFrom (findChunks p)
        go [] (Left i)  = [ReverseGraph (Left i) []]
        go (r:rs) p = [ReverseGraph (Right r) (go rs p)]

-- Prettily convert a ReverseGraph to a readable tree. This will give
-- us a recipe tree in reverse order, starting with the DONE, and
-- gradually going back to the ingredients.
prettyGraph :: ReverseGraph -> Text
prettyGraph = go 0
  where go n (ReverseGraph t rs) =
          indent n <> stepName t <> "\n" <> T.concat (map (go (n+2)) rs)
        indent n = T.replicate n " "

stepName :: Either IngredientList Text -> Text
stepName (Right t) = t
stepName (Left (IngredientList is)) =
  T.intercalate "; " [ ingName i | i <- is ]

ingName :: Ingredient -> Text
ingName (Ingredient (Just amt) name) = amt <> " " <> name
ingName (Ingredient Nothing name)    = name

showFragments :: Recipe -> Text
showFragments = T.pack . show . getChunks

showReverseTree :: Recipe -> Text
showReverseTree = prettyGraph . buildReverseGraph . getChunks