{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.EO.Phi.Metrics.Collect where
import Control.Lens ((+=))
import Control.Monad.State (State, execState, runState)
import Data.Foldable (forM_)
import Data.Generics.Labels ()
import Data.Maybe (catMaybes)
import Data.Traversable (forM)
import Language.EO.Phi.Metrics.Data (BindingMetrics (..), BindingsByPathMetrics (..), MetricsCount, ObjectMetrics (..), Path, ProgramMetrics (..))
import Language.EO.Phi.Rules.Common ()
import Language.EO.Phi.Syntax.Abs
type HeightSafe = Maybe Int
count :: (a -> Bool) -> [a] -> Int
count :: forall a. (a -> Bool) -> [a] -> Int
count a -> Bool
x = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
x
getHeight :: [Binding] -> [HeightSafe] -> HeightSafe
getHeight :: [Binding] -> [HeightSafe] -> HeightSafe
getHeight [Binding]
bindings [HeightSafe]
heights
| Bool
hasDeltaBinding = Int -> HeightSafe
forall a. a -> Maybe a
Just Int
1
| Bool
otherwise = HeightSafe
heightAttributes
where
heightAttributes :: HeightSafe
heightAttributes =
case [HeightSafe] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [HeightSafe]
heights of
[] -> HeightSafe
forall a. Maybe a
Nothing
[Int]
x -> Int -> HeightSafe
forall a. a -> Maybe a
Just ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
isBinding :: Binding -> Bool
isBinding = \case
DeltaBinding Bytes
_ -> Bool
True
Binding
_ -> Bool
False
hasDeltaBinding :: Bool
hasDeltaBinding = (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isBinding [Binding]
bindings
countDataless :: HeightSafe -> Int
countDataless :: HeightSafe -> Int
countDataless (Just Int
x)
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 = Int
1
| Bool
otherwise = Int
0
countDataless HeightSafe
_ = Int
1
type InspectM = State MetricsCount HeightSafe
class Inspectable a where
inspect :: a -> InspectM
instance Inspectable Binding where
inspect :: Binding -> InspectM
inspect :: Binding -> InspectM
inspect = \case
AlphaBinding Attribute
_ Object
obj -> Object -> InspectM
forall a. Inspectable a => a -> InspectM
inspect Object
obj
Binding
_ -> HeightSafe -> InspectM
forall a. a -> StateT MetricsCount Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeightSafe
forall a. Maybe a
Nothing
instance Inspectable Object where
inspect :: Object -> InspectM
inspect :: Object -> InspectM
inspect = \case
Formation [Binding]
bindings -> do
#formations += 1
heights <- forM bindings inspect
let height = getHeight bindings heights
#dataless += countDataless height
pure height
Application Object
obj [Binding]
bindings -> do
#applications += 1
_ <- inspect obj
forM_ bindings inspect
pure Nothing
ObjectDispatch Object
obj Attribute
_ -> do
#dispatches += 1
_ <- inspect obj
pure Nothing
Object
_ -> HeightSafe -> InspectM
forall a. a -> StateT MetricsCount Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeightSafe
forall a. Maybe a
Nothing
getThisObjectMetrics :: Object -> MetricsCount
getThisObjectMetrics :: Object -> MetricsCount
getThisObjectMetrics Object
obj = InspectM -> MetricsCount -> MetricsCount
forall s a. State s a -> s -> s
execState (Object -> InspectM
forall a. Inspectable a => a -> InspectM
inspect Object
obj) MetricsCount
forall a. Monoid a => a
mempty
getObjectByPath :: Object -> Path -> Either Path Object
getObjectByPath :: Object -> Path -> Either Path Object
getObjectByPath Object
object Path
path =
case Path
path of
[] -> Object -> Either Path Object
forall a b. b -> Either a b
Right Object
object
(String
p : Path
ps) ->
case Object
object of
Formation [Binding]
bindings ->
case [Object]
objectByPath' of
[] -> Path -> Either Path Object
forall a b. a -> Either a b
Left Path
path
(Object
x : [Object]
_) -> Object -> Either Path Object
forall a b. b -> Either a b
Right Object
x
where
objectByPath' :: [Object]
objectByPath' =
do
Binding
x <- [Binding]
bindings
Right Object
obj <-
case Binding
x of
AlphaBinding (Alpha (AlphaIndex String
name)) Object
obj | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
p -> [Object -> Path -> Either Path Object
getObjectByPath Object
obj Path
ps]
AlphaBinding (Label (LabelId String
name)) Object
obj | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
p -> [Object -> Path -> Either Path Object
getObjectByPath Object
obj Path
ps]
Binding
_ -> [Path -> Either Path Object
forall a b. a -> Either a b
Left Path
path]
Object -> [Object]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
obj
Object
_ -> Path -> Either Path Object
forall a b. a -> Either a b
Left Path
path
getBindingsByPathMetrics :: Object -> Path -> Either Path BindingsByPathMetrics
getBindingsByPathMetrics :: Object -> Path -> Either Path BindingsByPathMetrics
getBindingsByPathMetrics Object
object Path
path =
case Object -> Path -> Either Path Object
getObjectByPath Object
object Path
path of
Right (Formation [Binding]
bindings) ->
let attributes' :: [(HeightSafe, MetricsCount)]
attributes' = (InspectM -> MetricsCount -> (HeightSafe, MetricsCount))
-> MetricsCount -> InspectM -> (HeightSafe, MetricsCount)
forall a b c. (a -> b -> c) -> b -> a -> c
flip InspectM -> MetricsCount -> (HeightSafe, MetricsCount)
forall s a. State s a -> s -> (a, s)
runState MetricsCount
forall a. Monoid a => a
mempty (InspectM -> (HeightSafe, MetricsCount))
-> (Binding -> InspectM) -> Binding -> (HeightSafe, MetricsCount)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> InspectM
forall a. Inspectable a => a -> InspectM
inspect (Binding -> (HeightSafe, MetricsCount))
-> [Binding] -> [(HeightSafe, MetricsCount)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bindings
([HeightSafe]
_, [MetricsCount]
objectMetrics) = [(HeightSafe, MetricsCount)] -> ([HeightSafe], [MetricsCount])
forall a b. [(a, b)] -> ([a], [b])
unzip [(HeightSafe, MetricsCount)]
attributes'
bindingsMetrics :: [BindingMetrics]
bindingsMetrics = do
(Binding, MetricsCount)
x <- [Binding] -> [MetricsCount] -> [(Binding, MetricsCount)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Binding]
bindings [MetricsCount]
objectMetrics
case (Binding, MetricsCount)
x of
(AlphaBinding (Alpha (AlphaIndex String
name)) Object
_, MetricsCount
metrics) -> [BindingMetrics{String
MetricsCount
name :: String
metrics :: MetricsCount
$sel:name:BindingMetrics :: String
$sel:metrics:BindingMetrics :: MetricsCount
..}]
(AlphaBinding (Label (LabelId String
name)) Object
_, MetricsCount
metrics) -> [BindingMetrics{String
MetricsCount
$sel:name:BindingMetrics :: String
$sel:metrics:BindingMetrics :: MetricsCount
name :: String
metrics :: MetricsCount
..}]
(Binding, MetricsCount)
_ -> []
in BindingsByPathMetrics -> Either Path BindingsByPathMetrics
forall a b. b -> Either a b
Right (BindingsByPathMetrics -> Either Path BindingsByPathMetrics)
-> BindingsByPathMetrics -> Either Path BindingsByPathMetrics
forall a b. (a -> b) -> a -> b
$ BindingsByPathMetrics{Path
[BindingMetrics]
path :: Path
bindingsMetrics :: [BindingMetrics]
$sel:path:BindingsByPathMetrics :: Path
$sel:bindingsMetrics:BindingsByPathMetrics :: [BindingMetrics]
..}
Right Object
_ -> Path -> Either Path BindingsByPathMetrics
forall a b. a -> Either a b
Left Path
path
Left Path
path' -> Path -> Either Path BindingsByPathMetrics
forall a b. a -> Either a b
Left Path
path'
getObjectMetrics :: Object -> Maybe Path -> Either Path ObjectMetrics
getObjectMetrics :: Object -> Maybe Path -> Either Path ObjectMetrics
getObjectMetrics Object
object Maybe Path
path = do
let thisObjectMetrics :: MetricsCount
thisObjectMetrics = Object -> MetricsCount
getThisObjectMetrics Object
object
Maybe BindingsByPathMetrics
bindingsByPathMetrics <- Maybe Path
-> (Path -> Either Path BindingsByPathMetrics)
-> Either Path (Maybe BindingsByPathMetrics)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Path
path ((Path -> Either Path BindingsByPathMetrics)
-> Either Path (Maybe BindingsByPathMetrics))
-> (Path -> Either Path BindingsByPathMetrics)
-> Either Path (Maybe BindingsByPathMetrics)
forall a b. (a -> b) -> a -> b
$ \Path
path' -> Object -> Path -> Either Path BindingsByPathMetrics
getBindingsByPathMetrics Object
object Path
path'
ObjectMetrics -> Either Path ObjectMetrics
forall a. a -> Either Path a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectMetrics{Maybe BindingsByPathMetrics
MetricsCount
thisObjectMetrics :: MetricsCount
bindingsByPathMetrics :: Maybe BindingsByPathMetrics
$sel:bindingsByPathMetrics:ObjectMetrics :: Maybe BindingsByPathMetrics
$sel:thisObjectMetrics:ObjectMetrics :: MetricsCount
..}
getProgramMetrics :: Program -> Maybe Path -> Either Path ProgramMetrics
getProgramMetrics :: Program -> Maybe Path -> Either Path ProgramMetrics
getProgramMetrics (Program [Binding]
bindings) Maybe Path
path = do
ObjectMetrics{Maybe BindingsByPathMetrics
MetricsCount
$sel:bindingsByPathMetrics:ObjectMetrics :: ObjectMetrics -> Maybe BindingsByPathMetrics
$sel:thisObjectMetrics:ObjectMetrics :: ObjectMetrics -> MetricsCount
bindingsByPathMetrics :: Maybe BindingsByPathMetrics
thisObjectMetrics :: MetricsCount
..} <- Object -> Maybe Path -> Either Path ObjectMetrics
getObjectMetrics ([Binding] -> Object
Formation [Binding]
bindings) Maybe Path
path
ProgramMetrics -> Either Path ProgramMetrics
forall a. a -> Either Path a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramMetrics{$sel:programMetrics:ProgramMetrics :: MetricsCount
programMetrics = MetricsCount
thisObjectMetrics, Maybe BindingsByPathMetrics
bindingsByPathMetrics :: Maybe BindingsByPathMetrics
$sel:bindingsByPathMetrics:ProgramMetrics :: Maybe BindingsByPathMetrics
..}