{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DerivingStrategies #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Test.StateMachine.BoxDrawer
-- Copyright   :  (C) 2017, ATS Advanced Telematic Systems GmbH
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Mats Daniel Gustafsson <daniel@advancedtelematic.com>
-- Stability   :  provisional
-- Portability :  non-portable (GHC extensions)
--
-- This module contains functions for visualing a history of a parallel
-- execution.
--
-----------------------------------------------------------------------------

module Test.StateMachine.BoxDrawer
  ( EventType(..)
  , Fork(..)
  , exec
  ) where

import           Prelude
import           Text.PrettyPrint.ANSI.Leijen
                   (Doc, text, vsep)

import           Test.StateMachine.Types
                   (Pid(..))

------------------------------------------------------------------------

-- | Event invocation or response.
data EventType = Open | Close
  deriving stock (Int -> EventType -> ShowS
[EventType] -> ShowS
EventType -> String
(Int -> EventType -> ShowS)
-> (EventType -> String)
-> ([EventType] -> ShowS)
-> Show EventType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EventType -> ShowS
showsPrec :: Int -> EventType -> ShowS
$cshow :: EventType -> String
show :: EventType -> String
$cshowList :: [EventType] -> ShowS
showList :: [EventType] -> ShowS
Show)

data Event = Event EventType Pid String

data Cmd = Top | Start String | Active | Deactive | Ret String | Bottom

compile :: [Event] -> ([Cmd], [Cmd])
compile :: [Event] -> ([Cmd], [Cmd])
compile = (Cmd, Cmd) -> [Event] -> ([Cmd], [Cmd])
go (Cmd
Deactive, Cmd
Deactive)
  where
    infixr 9 `add`
    add :: (a,b) -> ([a], [b]) -> ([a], [b])
    add :: forall a b. (a, b) -> ([a], [b]) -> ([a], [b])
add (a
x,b
y) ([a]
xs, [b]
ys) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs, b
yb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
ys)

    set :: (a, a) -> Pid -> a -> (a, a)
    set :: forall a. (a, a) -> Pid -> a -> (a, a)
set (a
_x, a
y) (Pid Int
1) a
x' = (a
x', a
y)
    set (a
x, a
_y) (Pid Int
2) a
y' = (a
x, a
y')
    set (a, a)
_ Pid
pid a
_      = String -> (a, a)
forall a. HasCallStack => String -> a
error (String -> (a, a)) -> String -> (a, a)
forall a b. (a -> b) -> a -> b
$ String
"compile.set: unknown pid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Pid -> String
forall a. Show a => a -> String
show Pid
pid

    go :: (Cmd, Cmd) -> [Event] -> ([Cmd], [Cmd])
    go :: (Cmd, Cmd) -> [Event] -> ([Cmd], [Cmd])
go (Cmd, Cmd)
_ [] = ([], [])
    go (Cmd, Cmd)
st (Event EventType
Open Pid
pid String
l :  [Event]
rest) =
      (Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid Cmd
Top (Cmd, Cmd) -> ([Cmd], [Cmd]) -> ([Cmd], [Cmd])
forall a b. (a, b) -> ([a], [b]) -> ([a], [b])
`add` (Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid (String -> Cmd
Start String
l) (Cmd, Cmd) -> ([Cmd], [Cmd]) -> ([Cmd], [Cmd])
forall a b. (a, b) -> ([a], [b]) -> ([a], [b])
`add` (Cmd, Cmd) -> [Event] -> ([Cmd], [Cmd])
go ((Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid Cmd
Active) [Event]
rest
    go (Cmd, Cmd)
st (Event EventType
Close Pid
pid String
l :  [Event]
rest) =
      (Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid (String -> Cmd
Ret String
l) (Cmd, Cmd) -> ([Cmd], [Cmd]) -> ([Cmd], [Cmd])
forall a b. (a, b) -> ([a], [b]) -> ([a], [b])
`add` (Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid Cmd
Bottom (Cmd, Cmd) -> ([Cmd], [Cmd]) -> ([Cmd], [Cmd])
forall a b. (a, b) -> ([a], [b]) -> ([a], [b])
`add` (Cmd, Cmd) -> [Event] -> ([Cmd], [Cmd])
go ((Cmd, Cmd) -> Pid -> Cmd -> (Cmd, Cmd)
forall a. (a, a) -> Pid -> a -> (a, a)
set (Cmd, Cmd)
st Pid
pid Cmd
Deactive) [Event]
rest

size :: Cmd -> Int
size :: Cmd -> Int
size Cmd
Top       = Int
4
size (Start String
l) = Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l
size Cmd
Active    = Int
2
size Cmd
Deactive  = Int
0
size (Ret String
l)   = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l
size Cmd
Bottom    = Int
4

adjust :: Int -> Cmd -> String
adjust :: Int -> Cmd -> String
adjust Int
n Cmd
Top = String
"┌" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) Char
'─' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"┐"
adjust Int
n (Start String
l) = String
"│ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" │"
adjust Int
n Cmd
Active = String
"│" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"│"
adjust Int
n Cmd
Deactive = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Char
' '
adjust Int
n (Ret String
l) = String
"│ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"→ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" │"
adjust Int
n Cmd
Bottom = String
"└" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) Char
'─' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"┘"

next :: ([Cmd], [Cmd]) -> [String]
next :: ([Cmd], [Cmd]) -> [String]
next ([Cmd]
left, [Cmd]
right) = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([Cmd] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cmd]
left Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` [Cmd] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cmd]
right) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> ShowS
merge [String]
left' [String]
right'
  where
    left' :: [String]
left' = (Cmd -> String) -> [Cmd] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Cmd -> String
adjust (Int -> Cmd -> String) -> Int -> Cmd -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(Cmd -> Int) -> [Cmd] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Cmd -> Int
size [Cmd]
left) ([Cmd]
left [Cmd] -> [Cmd] -> [Cmd]
forall a. [a] -> [a] -> [a]
++ Cmd -> [Cmd]
forall a. a -> [a]
repeat Cmd
Deactive)
    right' :: [String]
right' = (Cmd -> String) -> [Cmd] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Cmd -> String
adjust (Int -> Cmd -> String) -> Int -> Cmd -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(Cmd -> Int) -> [Cmd] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Cmd -> Int
size [Cmd]
right) ([Cmd]
right [Cmd] -> [Cmd] -> [Cmd]
forall a. [a] -> [a] -> [a]
++ Cmd -> [Cmd]
forall a. a -> [a]
repeat Cmd
Deactive)
    merge :: String -> ShowS
merge String
x String
y = String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" │ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y

toEvent :: [(EventType, Pid)] -> ([String], [String]) -> [Event]
toEvent :: [(EventType, Pid)] -> ([String], [String]) -> [Event]
toEvent [] ([], [])             = []
toEvent [] ([String], [String])
ps = String -> [Event]
forall a. HasCallStack => String -> a
error (String -> [Event]) -> String -> [Event]
forall a b. (a -> b) -> a -> b
$ String
"toEvent: residue inputs: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String], [String]) -> String
forall a. Show a => a -> String
show ([String], [String])
ps
toEvent ((EventType
e , Pid Int
1):[(EventType, Pid)]
evT)  (String
x:[String]
xs, [String]
ys)   = EventType -> Pid -> String -> Event
Event EventType
e (Int -> Pid
Pid Int
1) String
x Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [(EventType, Pid)] -> ([String], [String]) -> [Event]
toEvent [(EventType, Pid)]
evT ([String]
xs, [String]
ys)
toEvent ((EventType
_e, Pid Int
1):[(EventType, Pid)]
_evT) ([]  , [String]
_ys)  = String -> [Event]
forall a. HasCallStack => String -> a
error String
"toEvent: no input from pid 1"
toEvent ((EventType
e , Pid Int
2):[(EventType, Pid)]
evT)  ([String]
xs  , String
y:[String]
ys) = EventType -> Pid -> String -> Event
Event EventType
e (Int -> Pid
Pid Int
2) String
y Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [(EventType, Pid)] -> ([String], [String]) -> [Event]
toEvent [(EventType, Pid)]
evT ([String]
xs, [String]
ys)
toEvent ((EventType
_e, Pid Int
2):[(EventType, Pid)]
_evT) ([String]
_xs , [])   = String -> [Event]
forall a. HasCallStack => String -> a
error String
"toEvent: no input from pid 2"
toEvent ((EventType, Pid)
e : [(EventType, Pid)]
_) ([String], [String])
_ = String -> [Event]
forall a. HasCallStack => String -> a
error (String -> [Event]) -> String -> [Event]
forall a b. (a -> b) -> a -> b
$ String
"toEvent: unknown pid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (EventType, Pid) -> String
forall a. Show a => a -> String
show (EventType, Pid)
e

compilePrefix :: [String] -> [Cmd]
compilePrefix :: [String] -> [Cmd]
compilePrefix [] = []
compilePrefix (String
cmd:String
res:[String]
prefix) = Cmd
Top Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: String -> Cmd
Start String
cmd Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: String -> Cmd
Ret String
res Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: Cmd
Bottom Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [String] -> [Cmd]
compilePrefix [String]
prefix
compilePrefix [String
cmd] = String -> [Cmd]
forall a. HasCallStack => String -> a
error (String -> [Cmd]) -> String -> [Cmd]
forall a b. (a -> b) -> a -> b
$ String
"compilePrefix: doesn't have response for cmd: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmd

data Fork a = Fork a a a
  deriving stock (forall a b. (a -> b) -> Fork a -> Fork b)
-> (forall a b. a -> Fork b -> Fork a) -> Functor Fork
forall a b. a -> Fork b -> Fork a
forall a b. (a -> b) -> Fork a -> Fork b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Fork a -> Fork b
fmap :: forall a b. (a -> b) -> Fork a -> Fork b
$c<$ :: forall a b. a -> Fork b -> Fork a
<$ :: forall a b. a -> Fork b -> Fork a
Functor

-- | Given a history, and output from processes generate Doc with boxes
exec :: [(EventType, Pid)] -> Fork [String] -> Doc
exec :: [(EventType, Pid)] -> Fork [String] -> Doc
exec [(EventType, Pid)]
evT (Fork [String]
lops [String]
pops [String]
rops) = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String]
preBoxes [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
parBoxes)
  where
    preBoxes :: [String]
preBoxes = let pref :: [Cmd]
pref = [String] -> [Cmd]
compilePrefix [String]
pops
               in (Cmd -> String) -> [Cmd] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Cmd -> String
adjust (Int -> Cmd -> String) -> Int -> Cmd -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Cmd -> Int) -> [Cmd] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Cmd -> Int) -> Cmd -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cmd -> Int
size) [Cmd]
pref [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 [String]
parBoxes)) [Cmd]
pref
    parBoxes :: [String]
parBoxes = ([Cmd], [Cmd]) -> [String]
next (([Cmd], [Cmd]) -> [String])
-> ([Event] -> ([Cmd], [Cmd])) -> [Event] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> ([Cmd], [Cmd])
compile ([Event] -> [String]) -> [Event] -> [String]
forall a b. (a -> b) -> a -> b
$ [(EventType, Pid)] -> ([String], [String]) -> [Event]
toEvent [(EventType, Pid)]
evT ([String]
lops, [String]
rops)