{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}

module Test.Sandwich.Interpreters.RunTree.Util where

import Control.Concurrent.STM
import Control.Monad.Free
import Control.Monad.Logger
import qualified Data.List as L
import Data.Sequence as Seq hiding ((:>))
import Data.String.Interpolate
import Data.Time.Clock
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec
import Text.Printf


-- | Wait for a tree, catching any synchronous exceptions and returning them as a list
waitForTree :: RunNode context -> IO Result
waitForTree :: forall context. RunNode context -> IO Result
waitForTree RunNode context
node = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
  forall a. TVar a -> STM a
readTVar (forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall a b. (a -> b) -> a -> b
$ forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Done {Result
statusResult :: Status -> Result
statusResult :: Result
statusResult} -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
statusResult
    NotStarted {} -> forall a. STM a
retry
    Running {} -> forall a. STM a
retry

-- | Append a log message outside of ExampleT. Only stored to in-memory logs, not disk.
-- Only for debugging the interpreter, should not be exposed.
appendLogMessage :: ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()
appendLogMessage :: forall msg. ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()
appendLogMessage TVar (Seq LogEntry)
logs msg
msg = do
  UTCTime
ts <- IO UTCTime
getCurrentTime
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Seq LogEntry)
logs (forall a. Seq a -> a -> Seq a
|> UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> LogEntry
LogEntry UTCTime
ts (String -> String -> String -> CharPos -> CharPos -> Loc
Loc String
"" String
"" String
"" (Int
0, Int
0) (Int
0, Int
0)) LogSource
"manual" LogLevel
LevelDebug (forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg))

getImmediateChildren :: Free (SpecCommand context m) () -> [Free (SpecCommand context m) ()]
getImmediateChildren :: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren (Free (It'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
ex Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> ExampleT context m ()
-> next
-> SpecCommand context m next
It'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
ex (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (Before'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
f Free (SpecCommand context m) ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> ExampleT context m ()
-> SpecFree context m ()
-> next
-> SpecCommand context m next
Before'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
f Free (SpecCommand context m) ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (After'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
f Free (SpecCommand context m) ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> ExampleT context m ()
-> SpecFree context m ()
-> next
-> SpecCommand context m next
After'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m ()
f Free (SpecCommand context m) ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (Introduce'' Maybe SrcLoc
loc NodeOptions
no String
l Label l intro
cl ExampleT context m intro
alloc intro -> ExampleT context m ()
cleanup SpecFree (LabelValue l intro :> context) m ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall intro (l :: Symbol) context (m :: * -> *) next.
Typeable intro =>
Maybe SrcLoc
-> NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> next
-> SpecCommand context m next
Introduce'' Maybe SrcLoc
loc NodeOptions
no String
l Label l intro
cl ExampleT context m intro
alloc intro -> ExampleT context m ()
cleanup SpecFree (LabelValue l intro :> context) m ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (IntroduceWith'' Maybe SrcLoc
loc NodeOptions
no String
l Label l intro
cl (intro -> ExampleT context m [Result]) -> ExampleT context m ()
action SpecFree (LabelValue l intro :> context) m ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall (l :: Symbol) intro context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> Label l intro
-> ((intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> next
-> SpecCommand context m next
IntroduceWith'' Maybe SrcLoc
loc NodeOptions
no String
l Label l intro
cl (intro -> ExampleT context m [Result]) -> ExampleT context m ()
action SpecFree (LabelValue l intro :> context) m ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (Around'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m [Result] -> ExampleT context m ()
f Free (SpecCommand context m) ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> (ExampleT context m [Result] -> ExampleT context m ())
-> SpecFree context m ()
-> next
-> SpecCommand context m next
Around'' Maybe SrcLoc
loc NodeOptions
no String
l ExampleT context m [Result] -> ExampleT context m ()
f Free (SpecCommand context m) ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (Describe'' Maybe SrcLoc
loc NodeOptions
no String
l Free (SpecCommand context m) ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> String
-> SpecFree context m ()
-> next
-> SpecCommand context m next
Describe'' Maybe SrcLoc
loc NodeOptions
no String
l Free (SpecCommand context m) ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Free (Parallel'' Maybe SrcLoc
loc NodeOptions
no Free (SpecCommand context m) ()
subspec Free (SpecCommand context m) ()
next)) = (forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall context (m :: * -> *) next.
Maybe SrcLoc
-> NodeOptions
-> SpecFree context m ()
-> next
-> SpecCommand context m next
Parallel'' Maybe SrcLoc
loc NodeOptions
no Free (SpecCommand context m) ()
subspec (forall (f :: * -> *) a. a -> Free f a
Pure ()))) forall a. a -> [a] -> [a]
: forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren Free (SpecCommand context m) ()
next
getImmediateChildren (Pure ()) = [forall (f :: * -> *) a. a -> Free f a
Pure ()]

countChildren :: Free (SpecCommand context m) () -> Int
countChildren :: forall context (m :: * -> *).
Free (SpecCommand context m) () -> Int
countChildren = forall (t :: * -> *) a. Foldable t => t a -> Int
L.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> [Free (SpecCommand context m) ()]
getImmediateChildren

countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int
countImmediateFolderChildren :: forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (Free (It'' Maybe SrcLoc
_loc NodeOptions
no String
_l ExampleT context m ()
_ex Free (SpecCommand context m) a
next))
  | NodeOptions -> Bool
nodeOptionsCreateFolder NodeOptions
no = Int
1 forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
countImmediateFolderChildren (Free (Introduce'' Maybe SrcLoc
_loc NodeOptions
no String
_l Label l intro
_cl ExampleT context m intro
_alloc intro -> ExampleT context m ()
_cleanup SpecFree (LabelValue l intro :> context) m ()
subspec Free (SpecCommand context m) a
next))
  | NodeOptions -> Bool
nodeOptionsCreateFolder NodeOptions
no = Int
1 forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspec forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
countImmediateFolderChildren (Free (IntroduceWith'' Maybe SrcLoc
_loc NodeOptions
no String
_l Label l intro
_cl (intro -> ExampleT context m [Result]) -> ExampleT context m ()
_action SpecFree (LabelValue l intro :> context) m ()
subspec Free (SpecCommand context m) a
next))
  | NodeOptions -> Bool
nodeOptionsCreateFolder NodeOptions
no = Int
1 forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspec forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
countImmediateFolderChildren (Free SpecCommand context m (Free (SpecCommand context m) a)
node)
  | NodeOptions -> Bool
nodeOptionsCreateFolder (forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) a)
node) = Int
1 forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) a)
node)
  | Bool
otherwise = forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (forall context (m :: * -> *) next.
SpecCommand context m next -> SpecFree context m ()
subspec SpecCommand context m (Free (SpecCommand context m) a)
node) forall a. Num a => a -> a -> a
+ forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) a)
node)
countImmediateFolderChildren (Pure a
_) = Int
0

maxFileNameLength :: Int
maxFileNameLength :: Int
maxFileNameLength = Int
150

nodeToFolderName :: String -> Int -> Int -> String
nodeToFolderName :: String -> Int -> Int -> String
nodeToFolderName String
name Int
1 Int
0 = Int -> String -> String
truncateFileNameToLength Int
maxFileNameLength forall a b. (a -> b) -> a -> b
$ String -> String
fixupName String
name
nodeToFolderName String
name Int
numSiblings Int
indexInParent = String
padding forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
truncateFileNameToLength (Int
maxFileNameLength forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
padding)) (String -> String
fixupName String
name)
  where
    paddingNeeded :: Int
paddingNeeded
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
10 = Int
1
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
100 = Int
2
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
1000 = Int
3
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
10000 = Int
4
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
100000 = Int
5
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
1000000 = Int
6
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
10000000 = Int
7
      | Int
numSiblings forall a. Ord a => a -> a -> Bool
< Int
100000000 = Int
8
      | Bool
otherwise = Int
15

    paddedNumber :: String
paddedNumber = forall r. PrintfType r => String -> r
printf [i|%0#{paddingNeeded :: Int}d|] Int
indexInParent

    padding :: String
padding = if | Int
numSiblings forall a. Eq a => a -> a -> Bool
== Int
1 -> String
""
                 | Bool
otherwise -> String
paddedNumber forall a. Semigroup a => a -> a -> a
<> String
"_"


charsToReplace :: [Char]
#ifdef mingw32_HOST_OS
charsToReplace = ['\\', '/', ':', '*', '?', '"', '<', '>', '|']
#else
charsToReplace :: String
charsToReplace = [Char
'/']
#endif

fixupName :: String -> String
fixupName :: String -> String
fixupName = forall a. Eq a => [a] -> a -> [a] -> [a]
replaceAll String
charsToReplace Char
'_'
  where
    replaceAll :: Eq a => [a] -> a -> [a] -> [a]
    replaceAll :: forall a. Eq a => [a] -> a -> [a] -> [a]
replaceAll [a]
from a
to = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \a
c -> if a
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [a]
from then a
to else a
c

truncateFileNameToLength :: Int -> String -> String
truncateFileNameToLength :: Int -> String -> String
truncateFileNameToLength Int
len String
x | forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
x forall a. Ord a => a -> a -> Bool
<= Int
len = String
x
truncateFileNameToLength Int
len String
x = String
"..." forall a. Semigroup a => a -> a -> a
<> (forall a. Int -> [a] -> [a]
takeEnd (Int
len forall a. Num a => a -> a -> a
- Int
3) String
x)

takeEnd :: Int -> [a] -> [a]
takeEnd :: forall a. Int -> [a] -> [a]
takeEnd Int
j [a]
xs = forall {a} {a}. [a] -> [a] -> [a]
f [a]
xs (forall a. Int -> [a] -> [a]
L.drop Int
j [a]
xs)
  where f :: [a] -> [a] -> [a]
f (a
_:[a]
zs) (a
_:[a]
ys) = [a] -> [a] -> [a]
f [a]
zs [a]
ys
        f [a]
zs [a]
_ = [a]
zs