diff options
Diffstat (limited to 'tools/resolver-visualize/Main.hs')
-rwxr-xr-x | tools/resolver-visualize/Main.hs | 30 |
1 files changed, 27 insertions, 3 deletions
diff --git a/tools/resolver-visualize/Main.hs b/tools/resolver-visualize/Main.hs index 61ceab32..d2799e92 100755 --- a/tools/resolver-visualize/Main.hs +++ b/tools/resolver-visualize/Main.hs @@ -218,6 +218,9 @@ type TreeViewStore = TreeStore TreeViewEntry type ChronViewStore = ListStore ChronViewEntry type RunListStore = ListStore (Integer, [ProcessingStep]) +data TargetFormat = PS | PNG + deriving(Eq, Ord, Show, Read) + -- | Parameters the user can set at the command-line. data Params = Params { @@ -227,11 +230,14 @@ data Params = -- | The first step to start rendering. firstStep :: Maybe Integer, -- | Where and whether to send dot output. - dotOutput :: Maybe String + dotOutput :: Maybe String, + -- | The target output format. + targetFormat :: Maybe TargetFormat } deriving(Eq, Ord, Show) defaultParams = Params { maxSteps = Nothing, firstStep = Nothing, - dotOutput = Nothing } + dotOutput = Nothing, + targetFormat = Nothing } -- | Shared context for the visualizer. data VisualizeContext = @@ -950,6 +956,11 @@ filterUserParams ("--first-step":(n:args)) params = let params' = params { first filterUserParams args params' filterUserParams ("--dot-output":(fn:args)) params = let params' = params { dotOutput = Just $ fn } in filterUserParams args params' +filterUserParams ("--target-format":(fmt:args)) params = + case reads fmt of + [] -> error (printf "Unknown target format %s" (show fmt)) + ((fmt', _):_) -> let params' = params { targetFormat = Just fmt' } in + filterUserParams args params' filterUserParams (arg:args) params = let (args', params') = filterUserParams args params in (arg:args', params') @@ -974,6 +985,19 @@ dotChoiceLabel :: LinkChoice -> String dotChoiceLabel lc@(LinkChoice c) = choiceText lc dotChoiceLabel Unknown = "" +inferTargetFormat :: Params -> TargetFormat +inferTargetFormat (Params { targetFormat = fmt, + dotOutput = output }) = + case fmt of + Nothing -> PS + Just fmt' -> fmt' + +cloudImage :: Params -> String +cloudImage params = + case inferTargetFormat params of + PS -> "cloud.eps" + PNG -> "cloud.png" + dotStepNode :: Params -> ProcessingStep -> Node dotStepNode params step = let n = node (name $ printf "step%d" (stepOrder step)) ..= ("label", printf "Step: %d\nScore: %d\nTier: %s" @@ -1004,7 +1028,7 @@ dotUnprocessedSuccs params step = unprocessed ++ excluded excluded = [ node (name $ printf "step%d" (stepOrder step)) ..= ("label", printf "%d nodes..." (stepBranchSize step)) ..= ("shape", "plaintext") - ..= ("image", "cloud.png") + ..= ("image", cloudImage params) | (Successor { successorStep = step }) <- stepSuccessors step, not $ inBounds params (stepOrder step) ] |