Fix metrics

.hlint.yaml

@@ -65,7 +65,7 @@
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
 - ignore:
     name: Unused LANGUAGE pragma
-    within: Language.EO.Phi.Metrics.Collect
+    within: Language.EO.Phi.Metrics
 
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~

eo-phi-normalizer/app/Main.hs

@@ -22,13 +22,16 @@ import Data.Foldable (forM_)
 import Control.Lens ((^.))
 import Data.Aeson (ToJSON)
 import Data.Aeson.Encode.Pretty (Config (..), Indent (..), defConfig, encodePrettyToTextBuilder')
-import Data.String.Interpolate (i)
+import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
+import Data.String.Interpolate (i, iii)
+import Data.Text qualified as T
 import Data.Text.Internal.Builder (toLazyText)
 import Data.Text.Lazy.Lens
 import GHC.Generics (Generic)
 import Language.EO.Phi (Bytes (Bytes), Object (Formation), Program (Program), parseProgram, printTree)
 import Language.EO.Phi.Dataize (dataizeRecursively, dataizeStep)
-import Language.EO.Phi.Metrics.Collect (collectMetrics)
+import Language.EO.Phi.Metrics (getProgramMetrics)
 import Language.EO.Phi.Rules.Common (ApplicationLimits (ApplicationLimits), applyRulesChainWith, applyRulesWith, defaultContext, objectSize)
 import Language.EO.Phi.Rules.Yaml (RuleSet (rules, title), convertRule, parseRuleSetFromFile)
 import Options.Applicative
@@ -58,6 +61,7 @@ data CLI'DataizePhi = CLI'DataizePhi
 data CLI'MetricsPhi = CLI'MetricsPhi
   { inputFile :: Maybe FilePath
   , outputFile :: Maybe FilePath
+  , programPath :: Maybe String
   }
   deriving (Show)
 
@@ -94,6 +98,21 @@ cliTransformPhiParser = do
   inputFile <- inputFileArg
   pure CLI'TransformPhi{..}
 
+programPathOption :: Parser (Maybe String)
+programPathOption =
+  optional $
+    strOption
+      ( long "bindings-by-path"
+          <> short 'b'
+          <> metavar "PATH"
+          <> help
+            [iii|
+              Report metrics for bindings of a formation accessible in a program by a PATH.
+              The default PATH is empty.
+              Example of a PATH: 'org.eolang'.
+            |]
+      )
+
 cliDataizePhiParser :: Parser CLI'DataizePhi
 cliDataizePhiParser = do
   rulesPath <- strOption (long "rules" <> short 'r' <> help [i|#{fileMetavarName} with user-defined rules. Must be specified.|] <> fileMetavar)
@@ -106,6 +125,7 @@ cliMetricsPhiParser :: Parser CLI'MetricsPhi
 cliMetricsPhiParser = do
   inputFile <- inputFileArg
   outputFile <- outputFileOption
+  programPath <- programPathOption
   pure CLI'MetricsPhi{..}
 
 metricsParserInfo :: ParserInfo CLI
@@ -161,7 +181,7 @@ getProgram :: Optparse.Context -> Maybe FilePath -> IO Program
 getProgram parserContext inputFile = do
   src <- maybe getContents' readFile inputFile
   case parseProgram src of
-    Left err -> die parserContext [i|"An error occurred when parsing the input program: #{err}|]
+    Left err -> die parserContext [i|An error occurred when parsing the input program: #{err}|]
     Right program -> pure program
 
 getLoggers :: Maybe FilePath -> IO (String -> IO (), String -> IO ())
@@ -172,6 +192,14 @@ getLoggers outputFile = do
     , \x -> hPutStr handle x >> hFlush handle
     )
 
+-- >>> splitStringOn "." "abra.cada.bra"
+-- ["abra","cada","bra"]
+--
+-- >>> splitStringOn "." ""
+-- []
+splitStringOn :: String -> String -> [String]
+splitStringOn sep s = filter (not . null) $ T.unpack <$> T.splitOn (T.pack sep) (T.pack s)
+
 main :: IO ()
 main = do
   opts <- customExecParser pprefs cliOpts
@@ -181,10 +209,20 @@ main = do
   case opts of
     CLI'MetricsPhi' CLI'MetricsPhi{..} -> do
       let parserContext = Optparse.Context metricsCommandName metricsParserInfo
-      program' <- getProgram parserContext inputFile
+      program <- getProgram parserContext inputFile
       (logStrLn, _) <- getLoggers outputFile
-      let metrics = collectMetrics program'
-      logStrLn $ encodeToJSONString metrics
+      let path = splitStringOn "." (fromMaybe "" programPath)
+          metrics = getProgramMetrics path program
+      case metrics of
+        Left path' ->
+          die
+            parserContext
+            [iii|
+              Could not find bindings at path '#{intercalate "." path}'
+              because an object at '#{intercalate "." path'}' is not a formation.
+            |]
+        Right metrics' -> do
+          logStrLn $ encodeToJSONString metrics'
     CLI'TransformPhi' CLI'TransformPhi{..} -> do
       let parserContext = Optparse.Context transformCommandName transformParserInfo
       program' <- getProgram parserContext inputFile

eo-phi-normalizer/eo-phi-normalizer.cabal

@@ -35,7 +35,7 @@ library
   exposed-modules:
       Language.EO.Phi
       Language.EO.Phi.Dataize
-      Language.EO.Phi.Metrics.Collect
+      Language.EO.Phi.Metrics
       Language.EO.Phi.Normalize
       Language.EO.Phi.Rules.Common
       Language.EO.Phi.Rules.PhiPaper

eo-phi-normalizer/src/Language/EO/Phi/Metrics.hs

@@ -0,0 +1,254 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.EO.Phi.Metrics where
+
+import Control.Lens ((+=))
+import Control.Monad (forM_)
+import Control.Monad.State (State, execState, runState)
+import Data.Aeson (FromJSON)
+import Data.Aeson.Types (ToJSON)
+import Data.Generics.Labels ()
+import Data.Traversable (forM)
+import GHC.Generics (Generic)
+import Language.EO.Phi.Rules.Common ()
+import Language.EO.Phi.Syntax.Abs
+
+data Metrics = Metrics
+  { dataless :: Int
+  , applications :: Int
+  , formations :: Int
+  , dispatches :: Int
+  }
+  deriving (Generic, Show, FromJSON, ToJSON, Eq)
+
+defaultMetrics :: Metrics
+defaultMetrics =
+  Metrics
+    { dataless = 0
+    , applications = 0
+    , formations = 0
+    , dispatches = 0
+    }
+
+instance Semigroup Metrics where
+  (<>) :: Metrics -> Metrics -> Metrics
+  x <> y =
+    Metrics
+      { dataless = x.dataless + y.dataless
+      , applications = x.applications + y.applications
+      , formations = x.formations + y.formations
+      , dispatches = x.dispatches + y.dispatches
+      }
+
+instance Monoid Metrics where
+  mempty :: Metrics
+  mempty = defaultMetrics
+
+data BindingMetrics = BindingMetrics
+  { name :: String
+  , metrics :: Metrics
+  }
+  deriving (Show, Generic, FromJSON, ToJSON, Eq)
+
+count :: (a -> Bool) -> [a] -> Int
+count x = length . filter x
+
+getHeight :: [Binding] -> [Int] -> Int
+getHeight bindings heights
+  | hasDeltaBinding = 1
+  | otherwise = heightAttributes
+ where
+  heightAttributes =
+    case heights of
+      [] -> 0
+      _ -> minimum heights + 1
+  hasDeltaBinding = not $ null [undefined | DeltaBinding _ <- bindings]
+
+countDataless :: Int -> Int
+countDataless x
+  | x == 0 || x > 2 = 1
+  | otherwise = 0
+
+class Inspectable a where
+  inspect :: a -> State Metrics Int
+
+instance Inspectable Binding where
+  inspect :: Binding -> State Metrics Int
+  inspect = \case
+    AlphaBinding _ obj -> do
+      inspect obj
+    _ -> pure 0
+
+instance Inspectable Object where
+  inspect :: Object -> State Metrics Int
+  inspect = \case
+    Formation bindings -> do
+      #formations += 1
+      heights <- forM bindings inspect
+      let height = getHeight bindings heights
+      #dataless += countDataless height
+      pure height
+    Application obj bindings -> do
+      #applications += 1
+      _ <- inspect obj
+      forM_ bindings inspect
+      pure 0
+    ObjectDispatch obj _ -> do
+      #dispatches += 1
+      _ <- inspect obj
+      pure 0
+    _ -> pure 0
+
+type Path = [String]
+
+data BindingsByPathMetrics = BindingsByPathMetrics
+  { path :: Path
+  , bindingsMetrics :: [BindingMetrics]
+  }
+  deriving (Show, Generic, FromJSON, ToJSON, Eq)
+
+data ObjectMetrics = ObjectMetrics
+  { bindingsByPathMetrics :: BindingsByPathMetrics
+  , thisObjectMetrics :: Metrics
+  }
+  deriving (Show, Generic, FromJSON, ToJSON, Eq)
+
+-- | Get metrics for an object
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α0 ↦ Φ.org.eolang.bytes( Δ ⤍ 00- ) ⟧"
+-- Metrics {dataless = 0, applications = 1, formations = 1, dispatches = 3}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, Δ ⤍ 00- ⟧"
+-- Metrics {dataless = 0, applications = 0, formations = 1, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α1 ↦ ⟦ Δ ⤍ 00- ⟧ ⟧"
+-- Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α1 ↦ ⟦ α2 ↦ ⟦ Δ ⤍ 00- ⟧ ⟧ ⟧"
+-- Metrics {dataless = 0, applications = 0, formations = 3, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ Δ ⤍ 00- ⟧"
+-- Metrics {dataless = 0, applications = 0, formations = 1, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧"
+-- Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧ ⟧"
+-- Metrics {dataless = 1, applications = 0, formations = 3, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧ ⟧ ⟧"
+-- Metrics {dataless = 2, applications = 0, formations = 4, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ org ↦ ⟦ ⟧ ⟧"
+-- Metrics {dataless = 1, applications = 0, formations = 2, dispatches = 0}
+--
+-- >>> getThisObjectMetrics "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧"
+-- Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 5}
+getThisObjectMetrics :: Object -> Metrics
+getThisObjectMetrics obj = execState (inspect obj) mempty
+
+-- | Get an object by a path within a given object.
+--
+-- If no object is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty.
+-- >>> getObjectByPath ["org", "eolang"] "⟦ org ↦ ⟦ eolang ↦ ⟦ x ↦ ⟦ φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, z ↦ ⟦ y ↦ ⟦ x ↦ ∅, φ ↦ ξ.x ⟧, φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧⟧"
+-- Right (Formation [AlphaBinding (Label (LabelId "x")) (Formation [AlphaBinding Phi (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (Alpha (AlphaIndex "\945\&0")) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),AlphaBinding (Label (LabelId "z")) (Formation [AlphaBinding (Label (LabelId "y")) (Formation [EmptyBinding (Label (LabelId "x")),AlphaBinding Phi (ObjectDispatch ThisObject (Label (LabelId "x")))]),AlphaBinding Phi (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (Alpha (AlphaIndex "\945\&0")) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),LambdaBinding (Function "Package")])
+--
+-- >>> getObjectByPath ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧"
+-- Right (ObjectDispatch (Formation [AlphaBinding (Label (LabelId "b")) (Formation [EmptyBinding (Label (LabelId "c")),AlphaBinding (Label (LabelId "d")) (Formation [AlphaBinding Phi (ObjectDispatch (ObjectDispatch ThisObject Rho) (Label (LabelId "c")))])]),AlphaBinding (Label (LabelId "e")) (ObjectDispatch (Application (ObjectDispatch ThisObject (Label (LabelId "b"))) [AlphaBinding (Label (LabelId "c")) (Formation [])]) (Label (LabelId "d")))]) (Label (LabelId "e")))
+getObjectByPath :: Path -> Object -> Either Path Object
+getObjectByPath path object =
+  case path of
+    [] -> Right object
+    (p : ps) ->
+      case object of
+        Formation bindings ->
+          case objectByPath' of
+            [] -> Left path
+            (x : _) -> Right x
+         where
+          objectByPath' =
+            do
+              x <- bindings
+              Right obj <-
+                case x of
+                  AlphaBinding (Alpha (AlphaIndex name)) obj | name == p -> [getObjectByPath ps obj]
+                  AlphaBinding (Label (LabelId name)) obj | name == p -> [getObjectByPath ps obj]
+                  _ -> [Left path]
+              pure obj
+        _ -> Left path
+
+-- | Get metrics for bindings of a formation that is accessible by a path within a given object.
+--
+-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty.
+-- >>> getBindingsByPathMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧"
+-- Left ["a"]
+--
+-- >>> getBindingsByPathMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧"
+-- Right (BindingsByPathMetrics {path = ["a"], bindingsMetrics = [BindingMetrics {name = "b", metrics = Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 2}},BindingMetrics {name = "e", metrics = Metrics {dataless = 1, applications = 1, formations = 1, dispatches = 2}}]})
+getBindingsByPathMetrics :: Path -> Object -> Either Path BindingsByPathMetrics
+getBindingsByPathMetrics path obj =
+  case getObjectByPath path obj of
+    Right (Formation bindings) ->
+      let attributes' = flip runState mempty . inspect <$> bindings
+          (_, objectMetrics) = unzip attributes'
+          bindingsMetrics = do
+            x <- zip bindings objectMetrics
+            case x of
+              (AlphaBinding (Alpha (AlphaIndex name)) _, metrics) -> [BindingMetrics{..}]
+              (AlphaBinding (Label (LabelId name)) _, metrics) -> [BindingMetrics{..}]
+              _ -> []
+       in Right $ BindingsByPathMetrics{..}
+    Right _ -> Left path
+    Left path' -> Left path'
+
+-- | Get metrics for an object and for bindings of a formation accessible by a given path.
+--
+-- Combine metrics produced by 'getThisObjectMetrics' and 'getBindingsByPathMetrics'.
+--
+-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty.
+-- >>> getObjectMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧"
+-- Left ["a"]
+--
+-- >>> getObjectMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧"
+-- Right (ObjectMetrics {bindingsByPathMetrics = BindingsByPathMetrics {path = ["a"], bindingsMetrics = [BindingMetrics {name = "b", metrics = Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 2}},BindingMetrics {name = "e", metrics = Metrics {dataless = 1, applications = 1, formations = 1, dispatches = 2}}]}, thisObjectMetrics = Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 4}})
+getObjectMetrics :: Path -> Object -> Either Path ObjectMetrics
+getObjectMetrics path obj = do
+  let thisObjectMetrics = getThisObjectMetrics obj
+  bindingsByPathMetrics <- getBindingsByPathMetrics path obj
+  pure ObjectMetrics{..}
+
+data ProgramMetrics = ProgramMetrics
+  { bindingsByPathMetrics :: BindingsByPathMetrics
+  , programMetrics :: Metrics
+  }
+  deriving (Show, Generic, FromJSON, ToJSON, Eq)
+
+-- | Get metrics for a program and for bindings of a formation accessible by a given path.
+--
+-- Combine metrics produced by 'getThisObjectMetrics' and 'getBindingsByPathMetrics'.
+--
+-- >>> getProgramMetrics ["org", "eolang"] "{⟦ org ↦ ⟦ eolang ↦ ⟦ x ↦ ⟦ φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, z ↦ ⟦ y ↦ ⟦ x ↦ ∅, φ ↦ ξ.x ⟧, φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧⟧ }"
+-- Right (ProgramMetrics {bindingsByPathMetrics = BindingsByPathMetrics {path = ["org","eolang"], bindingsMetrics = [BindingMetrics {name = "x", metrics = Metrics {dataless = 0, applications = 2, formations = 1, dispatches = 6}},BindingMetrics {name = "z", metrics = Metrics {dataless = 0, applications = 2, formations = 2, dispatches = 7}}]}, programMetrics = Metrics {dataless = 0, applications = 4, formations = 6, dispatches = 13}})
+--
+-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty.
+--
+-- >>> getProgramMetrics ["a"] "{⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧}"
+-- Left ["a"]
+getProgramMetrics :: Path -> Program -> Either Path ProgramMetrics
+getProgramMetrics path (Program bindings) = do
+  ObjectMetrics{..} <- getObjectMetrics path (Formation bindings)
+  pure ProgramMetrics{programMetrics = thisObjectMetrics, ..}