Add interactive shrink view to conformance-test-viewer

cardano-node/app/conformance-test-viewer.hs

@@ -0,0 +1,284 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-matches -Wno-unused-local-binds #-}
+
+module Main (main) where
+
+import           Prelude hiding (lookup)
+
+import           Data.Aeson (eitherDecode, encode, FromJSON, ToJSON, Value)
+import           Data.Aeson.Encode.Pretty (encodePretty)
+import           Data.Aeson.KeyMap (KeyMap)
+import qualified Data.ByteString.Lazy as BS
+import           Data.Char (isDigit)
+import           Data.List (groupBy)
+import           Data.Proxy
+import           Data.RoseTree
+import           Data.Scientific (Scientific)
+import           GHC.Generics
+import           ShrinkIndex
+import           System.Console.ANSI (clearScreen, setCursorPosition)
+import           System.Console.GetOpt
+import           System.Environment (getArgs)
+import           System.Exit
+import           System.IO (hPutStr, hPutChar, hSetEcho, hFlush, hSetBuffering, stdin, stdout, stderr, BufferMode(..))
+import           Test.QuickCheck (Arbitrary)
+import           Test.StateMachine.TreeDiff.Class (ediff, ToExpr(..))
+import           Test.StateMachine.TreeDiff.Pretty (prettyEditExpr)
+import qualified Text.PrettyPrint as PP (render)
+import           Text.Read (readEither)
+
+
+
+main :: IO ()
+main = do
+  opts <- getOptions
+
+  if optShowHelp opts
+    then showUsage >> exitSuccess
+    else pure ()
+
+  if optShowVersion opts
+    then showVersion >> exitSuccess
+    else pure ()
+
+  if optDebug opts
+    then analyzeTreeOf (Proxy :: Proxy Int) opts
+    else analyzeTreeOf (Proxy :: Proxy String) opts -- For now just a dummy implementation
+
+-- Analyze the shrink tree of a value of any type that
+-- implements `Arbitrary`, `FromJSON`, and `ToJSON`.
+analyzeTreeOf
+  :: forall a. (ToJSON a, FromJSON a, Arbitrary a, Show a, ToExpr a)
+  => Proxy a -> Options -> IO ()
+analyzeTreeOf _ opts = do
+  input <- case optInputPath opts of
+    Nothing -> BS.getContents
+    Just iPath -> BS.readFile iPath
+
+  testCase <- case eitherDecode input of
+    Right ok -> pure (ok :: a)
+    Left err -> do
+      errPutStrLn $ "Input decoding error: " <> err
+      exitFailure
+
+  let tree = arbitraryShrinkTree testCase
+
+  case optMode opts of
+    ShowDescendant -> do
+      let result = lookup (optShrinkIndex opts) tree
+      descendant <- case result of
+        Nothing -> do
+          errPutStrLn $ "Descendant does not exist. :("
+          exitFailure
+        Just ok -> pure ok
+
+      let bytes = if optPrettyPrint opts
+            then encodePretty descendant
+            else encode descendant
+
+      case optOutputPath opts of
+        Nothing -> BS.putStr bytes >> putStrLn ""
+        Just oPath -> BS.writeFile oPath bytes
+
+    Interactive -> do
+      hSetEcho stdout False
+      hSetBuffering stdin NoBuffering
+      let allShrinks = makeRoseTreeZipper $ applyRoseTreeWithIndex (,) $ makeRoseTree (\x -> (node x, branches x)) $ tree
+      interactWithShrinks allShrinks opts Nothing
+
+interactWithShrinks
+  :: (Show a, ToExpr a) => RoseTreeZipper ([Int], a) -> Options -> Maybe String -> IO ()
+interactWithShrinks zipper opts mMessage = do
+  clearScreen
+  setCursorPosition 0 0
+  let RoseTreeZipper tree@(RoseTree (index, u) _) _ prev = zipper
+  case prev of
+    Nothing -> putStrLn $ show u
+    Just (_,v) -> putStrLn $ PP.render $ prettyEditExpr $ ediff v u
+  putStrLn $ show index
+  case mMessage of
+    Nothing -> pure ()
+    Just msg -> putStrLn msg
+  -- mapM_ putStrLn $ flattenDepthFirst $ fmap mconcat $ prettyPrefixRoseTree tree
+  cmd <- readCommand
+  case cmd of
+    Quit -> pure ()
+    ToParent -> case toParent zipper of
+      Just zipper' -> interactWithShrinks zipper' opts Nothing
+      Nothing -> interactWithShrinks zipper opts $ Just "already at the root!"
+    ToLeftSibling -> case toLeftSibling zipper of
+      Just zipper' -> interactWithShrinks zipper' opts Nothing
+      Nothing -> interactWithShrinks zipper opts $ Just "already at the first sibling!"
+    ToRightSibling -> case toRightSibling zipper of
+      Just zipper' -> interactWithShrinks zipper' opts Nothing
+      Nothing -> interactWithShrinks zipper opts $ Just "already at the last sibling!"
+    ToFirstChild -> case toFirstChild zipper of
+      Just zipper' -> interactWithShrinks zipper' opts Nothing
+      Nothing -> interactWithShrinks zipper opts $ Just "this node has no children!"
+    _ -> interactWithShrinks zipper opts Nothing
+
+
+
+getOptions :: IO Options
+getOptions = do
+  argv <- getArgs
+
+  let (actions, params, errs) = getOpt Permute options argv
+
+  if null errs
+    then pure ()
+    else do
+      errPutStrLn "option error(s):"
+      mapM_ errPutStrLn errs
+      showUsage >> exitFailure
+
+  -- Options as parsed only from the flags.
+  opts <- case compose actions defaultOpts of
+    Right ok -> pure ok
+    Left err -> do
+      errPutStrLn $ "Option parsing error: " <> err
+      showUsage >> exitFailure
+
+  -- Adjust to account for the input path being passed as
+  -- an argument instead of a flag.
+  case params of
+    [] -> pure opts
+    [inputPath] -> pure $ opts { optInputPath = Just inputPath }
+    _ -> do
+      errPutStrLn $ "unrecognized arguments: " <> show params
+      showUsage >> exitFailure
+
+
+
+data Mode
+  = ShowDescendant
+  | Interactive
+  deriving (Eq, Show)
+
+data Options = Options
+  { optShowHelp    :: Bool           -- ^ Show usage?
+  , optShowVersion :: Bool           -- ^ Show version info?
+  , optInputPath   :: Maybe FilePath
+  , optShrinkIndex :: ShrinkIndex
+  , optOutputPath  :: Maybe FilePath
+  , optPrettyPrint :: Bool
+  , optDebug       :: Bool
+  , optMode        :: Mode
+  } deriving (Eq, Show)
+
+defaultOpts :: Options
+defaultOpts = Options
+  { optShowHelp    = False
+  , optShowVersion = False
+  , optInputPath   = Nothing
+  , optShrinkIndex = mempty
+  , optOutputPath  = Nothing
+  , optPrettyPrint = True
+  , optDebug       = False
+  , optMode        = ShowDescendant
+  }
+
+options :: [OptDescr (Options -> Either String Options)]
+options =
+  [ let munge opts = pure $ opts { optShowHelp = True }
+    in Option ['?'] ["help"] (NoArg munge)
+        "show usage"
+
+  , let munge opts = pure $ opts { optShowVersion = True }
+    in Option [] ["version"] (NoArg munge)
+        "show version information"
+
+  , let munge mPath opts = pure $ opts { optInputPath = mPath }
+    in Option [] ["input"] (OptArg munge "FILE")
+        "read from FILE (default is stdin)"
+
+  , let
+      munge d opts = do
+        ix <- parseShrinkIndexOption d
+        pure $ opts { optShrinkIndex = ix }
+    in
+      Option [] ["shrink-index"] (ReqArg munge "STRING")
+        "comma delimited list of natural numbers, e.g. '1,3,3,7' (default is the empty list)"
+
+  , let munge mPath opts = pure $ opts { optOutputPath = mPath }
+    in Option [] ["output"] (OptArg munge "FILE")
+        "write to FILE (default is stdout)"
+
+  , let munge opts = pure $ opts { optPrettyPrint = False }
+    in Option [] ["notpretty"] (NoArg munge)
+        "do not pretty print output"
+
+  , let munge opts = pure $ opts { optDebug = True }
+    in Option [] ["debug"] (NoArg munge)
+        "Use trees of integers instead of test scripts"
+
+  , let munge opts = pure $ opts { optMode = Interactive }
+    in Option [] ["interactive"] (NoArg munge)
+        "navigate the shrink tree"
+  ]
+
+-- Very permissive; given a string, interpret any maximal contiguous
+-- substring of digits as a number and all other characters as delimiters.
+--   parseShrinkIndex "1,2,34"    == Right path [1,2,34]
+--   parseShrinkIndex "1,,2,,,34" == Right path [1,2,34]
+--   parseShrinkIndex "1 2 34"    == Right path [1,2,34]
+--   parseShrinkIndex "o1w2o34w"  == Right path [1,2,34]
+parseShrinkIndexOption :: String -> Either String ShrinkIndex
+parseShrinkIndexOption =
+  fmap path . sequenceA . fmap readEither . filter (all isDigit) . groupBy bothDigits
+  where bothDigits u v = isDigit u && isDigit v
+
+
+
+-- Like putStrLn, but for stderr.
+errPutStrLn :: String -> IO ()
+errPutStrLn msg = hPutStr stderr msg >> hPutChar stderr '\n'
+
+showUsage :: IO ()
+showUsage = do
+  let header = "USAGE: " <> nameString <> " [--OPTION...] [PATH]"
+  putStrLn $ usageInfo header options
+
+showVersion :: IO ()
+showVersion = putStrLn versionString
+
+nameString :: String
+nameString = "conformance-test-viewer"
+
+versionString :: String
+versionString = nameString <> "-0.0"
+
+
+
+data Command
+  = NoOp
+  | ToParent
+  | ToLeftSibling
+  | ToRightSibling
+  | ToFirstChild
+  | Quit
+  deriving (Eq, Show)
+
+readCommand :: IO Command
+readCommand = do
+  c1 <- getChar
+  case c1 of
+    '\ESC' -> do
+      c2 <- getChar
+      c3 <- getChar
+      case (c2, c3) of
+        ('[', 'A') -> pure ToLeftSibling
+        ('[', 'B') -> pure ToRightSibling
+        ('[', 'C') -> pure ToFirstChild
+        ('[', 'D') -> pure ToParent
+        _ -> pure NoOp
+    'q' -> pure Quit
+    _   -> pure NoOp

cardano-node/cardano-node.cabal

@@ -302,11 +302,12 @@ library conformance-testlib
   import:               project-config
   hs-source-dirs:       src-conformance-test
   exposed-modules:      ExitCodes
-                        MiniProtocols
-                        Options
-                        Query
-                        Server
-                        ShrinkIndex
+                      , MiniProtocols
+                      , Options
+                      , Query
+                      , Server
+                      , ShrinkIndex
+                      , Data.RoseTree
   build-depends:        base
                       , containers
                       , comonad
@@ -318,7 +319,7 @@ library conformance-testlib
                       , ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}
                       , ouroboros-consensus-diffusion:unstable-consensus-conformance-testlib
                       , ouroboros-network-api
-                      , aeson
+                    --  , aeson
                       , bytestring
                       , ouroboros-network-framework
                       , network
@@ -360,6 +361,21 @@ executable conformance-test-runner
                       , QuickCheck
                       , cardano-api
 
+executable conformance-test-viewer
+  import:               project-config
+  hs-source-dirs:       app
+  main-is:              conformance-test-viewer.hs
+  build-depends:        base
+                      , cardano-node:conformance-testlib
+                      , aeson
+                      , aeson-pretty
+                      , ansi-terminal
+                      , bytestring
+                      , pretty
+                      , QuickCheck
+                      , quickcheck-state-machine
+                      , scientific
+
 test-suite conformance-testlib-test
   import:               project-config
   hs-source-dirs:       test