module Haxible.Report (reportTiming) where

import Data.Aeson
import Data.List (sortOn)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text qualified as Text
import Haxible.Prelude

reportTiming :: NonEmpty Value -> Text
reportTiming :: NonEmpty Value -> Text
reportTiming NonEmpty Value
rawResults =
  [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [Text
"@startuml", Text
"scale 1 as 100 pixels"]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"concise " (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
orderedKeys)
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, (Integer, Integer, Text)) -> [Text])
-> [(Text, (Integer, Integer, Text))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, (Integer, Integer, Text)) -> [Text]
toTiming (Map Text (Integer, Integer, Text)
-> [(Text, (Integer, Integer, Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Integer, Integer, Text)
modules)
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"@enduml"]
  where
    orderedKeys :: [Text]
orderedKeys = (Text, (Integer, Integer, Text)) -> Text
forall a b. (a, b) -> a
fst ((Text, (Integer, Integer, Text)) -> Text)
-> [(Text, (Integer, Integer, Text))] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, (Integer, Integer, Text)) -> Integer)
-> [(Text, (Integer, Integer, Text))]
-> [(Text, (Integer, Integer, Text))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Text
_, (Integer
s, Integer
_, Text
_)) -> Integer
s) (Map Text (Integer, Integer, Text)
-> [(Text, (Integer, Integer, Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Integer, Integer, Text)
modules)
    results :: [Value]
    results :: [Value]
results = [Value] -> [Value]
forall a. [a] -> [a]
reverse ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ ([Value] -> Value -> [Value])
-> [Value] -> NonEmpty Value -> [Value]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Value] -> Value -> [Value]
go [Value]
forall a. Monoid a => a
mempty NonEmpty Value
rawResults
      where
        go :: [Value] -> Value -> [Value]
go [Value]
acc Value
x = case Getting (First (Vector Value)) Value (Vector Value)
-> Value -> Maybe (Vector Value)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"results" ((Value -> Const (First (Vector Value)) Value)
 -> Value -> Const (First (Vector Value)) Value)
-> Getting (First (Vector Value)) Value (Vector Value)
-> Getting (First (Vector Value)) Value (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First (Vector Value)) Value (Vector Value)
forall t. AsValue t => Prism' t (Vector Value)
_Array) Value
x of
          Just Vector Value
xs -> Vector Value -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Value
xs [Value] -> [Value] -> [Value]
forall a. Semigroup a => a -> a -> a
<> [Value]
acc
          Maybe (Vector Value)
Nothing -> Value
x Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
acc

    scaleTime :: Integer -> Integer
    scaleTime :: Integer -> Integer
scaleTime Integer
x = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minDate) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
step)

    toTiming :: (Text, (Integer, Integer, Text)) -> [Text]
    toTiming :: (Text, (Integer, Integer, Text)) -> [Text]
toTiming (Text
name, (Integer -> Integer
scaleTime -> Integer
start, Integer -> Integer
scaleTime -> Integer
end, Text
name')) =
      [ Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name,
        [Text] -> Text
Text.unwords [String -> Text
forall source target. From source target => source -> target
from (Integer -> String
forall a. Show a => a -> String
show Integer
start), Text
"is", Text -> Text
quote Text
name'],
        [Text] -> Text
Text.unwords [String -> Text
forall source target. From source target => source -> target
from (Integer -> String
forall a. Show a => a -> String
show Integer
end), Text
"is", Text
"{hidden}"]
      ]

    step :: Double
step = Double
9 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto @Double (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ Integer
maxDate Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minDate)
    minDate, maxDate :: Integer
    minDate :: Integer
minDate = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Value -> Integer) -> [Value] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value -> Integer
forall {c} {s}. (Integral c, AsValue s) => Text -> s -> c
getNumber Text
"__haxible_start") [Value]
results
    maxDate :: Integer
maxDate = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Value -> Integer) -> [Value] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value -> Integer
forall {c} {s}. (Integral c, AsValue s) => Text -> s -> c
getNumber Text
"__haxible_end") [Value]
results
    getNumber :: Text -> s -> c
getNumber Text
key' = Scientific -> c
forall a b. (RealFrac a, Integral b) => a -> b
round (Scientific -> c) -> (s -> Scientific) -> s -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Maybe Scientific -> Scientific
forall a. a -> Maybe a -> a
fromMaybe (String -> Scientific
forall a. HasCallStack => String -> a
error (String -> Scientific) -> String -> Scientific
forall a b. (a -> b) -> a -> b
$ String
"missing attributes: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall source target. From source target => source -> target
from Text
key') (Maybe Scientific -> Scientific)
-> (s -> Maybe Scientific) -> s -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Scientific) s Scientific -> s -> Maybe Scientific
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' s Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
key' ((Value -> Const (First Scientific) Value)
 -> s -> Const (First Scientific) s)
-> ((Scientific -> Const (First Scientific) Scientific)
    -> Value -> Const (First Scientific) Value)
-> Getting (First Scientific) s Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scientific -> Const (First Scientific) Scientific)
-> Value -> Const (First Scientific) Value
forall t. AsNumber t => Prism' t Scientific
_Number)
    modules :: Map Text (Integer, Integer, Text)
    modules :: Map Text (Integer, Integer, Text)
modules = (Map Text (Integer, Integer, Text)
 -> Value -> Map Text (Integer, Integer, Text))
-> Map Text (Integer, Integer, Text)
-> [Value]
-> Map Text (Integer, Integer, Text)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Value
 -> Map Text (Integer, Integer, Text)
 -> Map Text (Integer, Integer, Text))
-> Map Text (Integer, Integer, Text)
-> Value
-> Map Text (Integer, Integer, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value
-> Map Text (Integer, Integer, Text)
-> Map Text (Integer, Integer, Text)
go) Map Text (Integer, Integer, Text)
forall a. Monoid a => a
mempty [Value]
results
      where
        go :: Value -> Map Text (Integer, Integer, Text) -> Map Text (Integer, Integer, Text)
        go :: Value
-> Map Text (Integer, Integer, Text)
-> Map Text (Integer, Integer, Text)
go Value
v Map Text (Integer, Integer, Text)
acc = Text
-> (Integer, Integer, Text)
-> Map Text (Integer, Integer, Text)
-> Map Text (Integer, Integer, Text)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
moduleID (Text -> Value -> Integer
forall {c} {s}. (Integral c, AsValue s) => Text -> s -> c
getNumber Text
"__haxible_start" Value
v, Text -> Value -> Integer
forall {c} {s}. (Integral c, AsValue s) => Text -> s -> c
getNumber Text
"__haxible_end" Value
v, Text
name) Map Text (Integer, Integer, Text)
acc
          where
            moduleID :: Text
moduleID = [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Map Text (Integer, Integer, Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Text (Integer, Integer, Text)
acc) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Integer -> Text) -> [Integer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> Text
module_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show @Integer Integer
i)) [Integer
0 ..]
            module_ :: Text
module_ = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (String -> Text
forall a. HasCallStack => String -> a
error String
"no module") (Getting (First Text) Value Text -> Value -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"__haxible_module" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String) Value
v)
            name :: Text
name = case Vector Value -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector Value -> [Value]) -> Vector Value -> [Value]
forall a b. (a -> b) -> a -> b
$ Vector Value -> Maybe (Vector Value) -> Vector Value
forall a. a -> Maybe a -> a
fromMaybe (String -> Vector Value
forall a. HasCallStack => String -> a
error String
"no name?") (Getting (First (Vector Value)) Value (Vector Value)
-> Value -> Maybe (Vector Value)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"__haxible_play" ((Value -> Const (First (Vector Value)) Value)
 -> Value -> Const (First (Vector Value)) Value)
-> Getting (First (Vector Value)) Value (Vector Value)
-> Getting (First (Vector Value)) Value (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"tasks" ((Value -> Const (First (Vector Value)) Value)
 -> Value -> Const (First (Vector Value)) Value)
-> Getting (First (Vector Value)) Value (Vector Value)
-> Getting (First (Vector Value)) Value (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First (Vector Value)) Value (Vector Value)
forall t. AsValue t => Prism' t (Vector Value)
_Array) Value
v) of
              [Value
x] -> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"task" (Getting (First Text) Value Text -> Value -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"name" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String) Value
x)
              [Value]
_ -> String -> Text
forall a. HasCallStack => String -> a
error String
"No task found"