Add count-aborts binary

dev-tools/context-logs/Main.hs

@@ -0,0 +1,39 @@
+{- | Stand-alone parser executable for testing and profiling
+
+Copyright   : (c) Runtime Verification, 2022
+License     : BSD-3-Clause
+-}
+module Main (
+    main,
+) where
+
+import Control.Monad (foldM, forM_)
+import Data.Aeson (ToJSON (toJSON), decode)
+import Data.Aeson.Encode.Pretty
+import Data.ByteString.Lazy.Char8 qualified as BS
+import Data.List (foldl')
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (unpack)
+import System.Environment (getArgs)
+import Types
+
+{- | Tests textual kore parser with given arguments and reports
+   internalisation results.
+
+   * Files given as arguments are parsed and internalised.  When a
+   * directory is given as an argument, it is (recursively) searched
+   * for files named "*.kore", which are parsed and internalised.
+-}
+main :: IO ()
+main =
+    getArgs >>= \case
+        ["tree", file] -> do
+            nested <- foldl' (foldl' toNested) (Nested mempty) . map decode . BS.lines <$> BS.readFile file
+            BS.putStrLn $ encodePretty' defConfig{confIndent = Spaces 2} $ toJSON nested
+        "aborts" : files -> do
+            let countContexts m f = foldl' (foldl' countAborts) m . map decode . BS.lines <$> BS.readFile f
+            (counts, rIdTorLoc) <- foldM countContexts mempty files
+            forM_ (Map.toList counts) $ \(k, v) ->
+                putStrLn $ unpack k <> " | " <> unpack (fromMaybe "-" $ Map.lookup k rIdTorLoc) <> " | " <> show v
+        _ -> error "invalid option"

dev-tools/context-logs/Types.hs

@@ -0,0 +1,62 @@
+module Types (module Types) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.=))
+import Data.Aeson.Key (fromText, toString)
+import Data.Aeson.KeyMap (toList)
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Sequence (Seq (..))
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+
+data Context = Plain Text | Ref Text Text deriving (Eq, Ord)
+
+toText :: Context -> Text
+toText = \case
+    Plain t -> t
+    Ref k v -> k <> " " <> v
+
+instance FromJSON Context where
+    parseJSON (String t) = pure $ Plain t
+    parseJSON (Object o) | [(k, String v)] <- toList o = pure $ Ref (pack $ toString k) v
+    parseJSON _ = fail "Invalid context"
+
+data LogMessage = LogMessage
+    { context :: Seq Context
+    , message :: Value
+    }
+    deriving (Generic, FromJSON)
+
+newtype Nested = Nested (Seq Value, Map Context Nested)
+
+instance ToJSON Nested where
+    toJSON (Nested (vs, m))
+        | null vs = object m'
+        | otherwise = object $ "logs" .= vs : m'
+      where
+        m' = [(fromText $ toText k, toJSON v) | (k, v) <- Map.toList m]
+
+insertAt :: Seq Context -> Value -> Nested -> Nested
+insertAt Empty v (Nested (vs, nested)) = Nested (vs :|> v, nested)
+insertAt (c :<| cs) v (Nested (vs, nested)) =
+    Nested
+        ( vs
+        , flip (Map.insert c) nested $
+            insertAt cs v $
+                case Map.lookup c nested of
+                    Nothing -> Nested mempty
+                    Just subtree -> subtree
+        )
+
+toNested :: Nested -> LogMessage -> Nested
+toNested n LogMessage{context, message} =
+    insertAt context message n
+
+countAborts :: (Map Text Int, Map Text Text) -> LogMessage -> (Map Text Int, Map Text Text)
+countAborts maps@(countMap, ruleMap) LogMessage{context, message} = case context of
+    (_ :|> Ref "rewrite" ruleId :|> Plain "match" :|> Plain "abort") -> increment ruleId
+    (_ :|> Ref "rewrite" ruleId :|> Plain "abort") -> increment ruleId
+    (_ :|> Ref "rewrite" ruleId :|> Plain "detail") | String ruleLoc <- message -> (countMap, Map.insert ruleId ruleLoc ruleMap)
+    _ -> maps
+  where
+    increment rid = (Map.alter (maybe (Just 1) (Just . (+ 1))) rid countMap, ruleMap)

dev-tools/package.yaml

@@ -89,6 +89,21 @@ executables:
       - transformers
     ghc-options:
       - -rtsopts
+  context-logs:
+    source-dirs: context-logs
+    main: Main.hs
+    dependencies:
+      - aeson
+      - aeson-pretty
+      - base
+      - bytestring
+      - containers
+      - directory
+      - filepath
+      - text
+      - transformers
+    ghc-options:
+      - -rtsopts
   parsetest-binary:
     source-dirs: parsetest-binary
     main: ParsetestBinary.hs