{-# 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 = STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$
  TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar (RunNodeCommonWithStatus
  (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus (RunNodeCommonWithStatus
   (TVar Status) (Var (Seq LogEntry)) (Var Bool)
 -> TVar Status)
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall a b. (a -> b) -> a -> b
$ RunNode context
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) STM Status -> (Status -> STM Result) -> STM Result
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Done {Result
statusResult :: Result
statusResult :: Status -> Result
statusResult} -> Result -> STM Result
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
statusResult
    NotStarted {} -> STM Result
forall a. STM a
retry
    Running {} -> STM Result
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 => Var (Seq LogEntry) -> msg -> IO ()
appendLogMessage Var (Seq LogEntry)
logs msg
msg = do
  UTCTime
ts <- IO UTCTime
getCurrentTime
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (Seq LogEntry) -> (Seq LogEntry -> Seq LogEntry) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Var (Seq LogEntry)
logs (Seq LogEntry -> LogEntry -> Seq LogEntry
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 (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg))

-- | Count how many folder children are present as children or siblings of the given node.
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = Free (SpecCommand context m) a -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren Free (SpecCommand context m) a
next
  | Bool
otherwise = SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
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 (SpecCommand context m (Free (SpecCommand context m) a)
-> NodeOptions
forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) a)
node) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (SpecCommand context m (Free (SpecCommand context m) a)
-> Free (SpecCommand context m) a
forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) a)
node)
  | Bool
otherwise = Free (SpecCommand context m) () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (SpecCommand context m (Free (SpecCommand context m) a)
-> Free (SpecCommand context m) ()
forall context (m :: * -> *) next.
SpecCommand context m next -> SpecFree context m ()
subspec SpecCommand context m (Free (SpecCommand context m) a)
node) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) a -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (SpecCommand context m (Free (SpecCommand context m) a)
-> Free (SpecCommand context m) a
forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) a)
node)
countImmediateFolderChildren (Pure a
_) = Int
0

-- | Count how many folder children are present as children of the given node.
countSubspecFolderChildren :: Free (SpecCommand context m) a -> Int
countSubspecFolderChildren :: forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countSubspecFolderChildren (Free (It'' {})) = Int
0
countSubspecFolderChildren (Free (Introduce'' {SpecFree (LabelValue l intro :> context) m ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
subspecAugmented :: ()
subspecAugmented})) = SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspecAugmented
countSubspecFolderChildren (Free (IntroduceWith'' {SpecFree (LabelValue l intro :> context) m ()
subspecAugmented :: ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
subspecAugmented})) = SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren SpecFree (LabelValue l intro :> context) m ()
subspecAugmented
countSubspecFolderChildren (Free SpecCommand context m (Free (SpecCommand context m) a)
node) = Free (SpecCommand context m) () -> Int
forall context (m :: * -> *) a.
Free (SpecCommand context m) a -> Int
countImmediateFolderChildren (SpecCommand context m (Free (SpecCommand context m) a)
-> Free (SpecCommand context m) ()
forall context (m :: * -> *) next.
SpecCommand context m next -> SpecFree context m ()
subspec SpecCommand context m (Free (SpecCommand context m) a)
node)
countSubspecFolderChildren (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 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
fixupName String
name
nodeToFolderName String
name Int
numSiblings Int
indexInParent = String
padding String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
truncateFileNameToLength (Int
maxFileNameLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
padding)) (String -> String
fixupName String
name)
  where
    paddingNeeded :: Int
paddingNeeded
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int
1
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100 = Int
2
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1000 = Int
3
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10000 = Int
4
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100000 = Int
5
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1000000 = Int
6
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10000000 = Int
7
      | Int
numSiblings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100000000 = Int
8
      | Bool
otherwise = Int
15

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

    padding :: String
padding = if | Int
numSiblings Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> String
""
                 | Bool
otherwise -> String
paddedNumber String -> String -> String
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 = String -> Char -> String -> String
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 = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a]) -> (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ \a
c -> if a
c a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len = String
x
truncateFileNameToLength Int
len String
x = String
"..." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Int -> String -> String
forall a. Int -> [a] -> [a]
takeEnd (Int
len Int -> Int -> Int
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 = [a] -> [a] -> [a]
forall {a} {a}. [a] -> [a] -> [a]
f [a]
xs (Int -> [a] -> [a]
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