<commit_before>{-# OPTIONS -fglasgow-exts #-}

import StackSet

import Data.Maybe
import System.Environment
import Control.Exception    (assert)
import Control.Monad
import Test.QuickCheck hiding (promote)
import System.IO
import System.Random
import Text.Printf
import Data.List            (nub,sort,group,sort,intersperse)
import Data.Map             (keys,elems)

-- ---------------------------------------------------------------------
-- QuickCheck properties for the StackSet

-- | Height of stack 'n'
height :: WorkspaceId -> StackSet a -> Int
height i w = length (index i w)

-- build (non-empty) StackSets with between 1 and 100 stacks
instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where
    arbitrary = do
        sz <- choose (1,20)
        n  <- choose (0,sz-1)
        sc <- choose (1,sz)
        ls <- vector sz
        return $ fromList (fromIntegral n,sc,ls)
    coarbitrary = error "no coarbitrary for StackSet"

prop_id x = fromList (toList x) == x
    where _ = x :: T

prop_member1 i n m = member i (push i x)
    where x = empty n m :: T

prop_member2 i x = not (member i (delete i x))
    where _ = x :: T

prop_member3 i n m = member i (empty n m :: T) == False

prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n
    where x  = empty n m :: T

prop_currentpush is n m = n > 0 ==>
    height (current x) (foldr push x js) == length js
    where
        js = nub is
        x = empty n m :: T

prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is
    where _ = x :: T

prop_peekmember x = case peek x of
                            Just w  -> member w x
                            Nothing -> True {- then we don't know anything -}
    where _ = x :: T

type T = StackSet Int

prop_delete_uniq i x = not (member i x) ==> delete i x == x
    where _ = x :: T

prop_delete2 i x =
    delete i x == delete i (delete i x)
    where _ = x :: T

prop_rotaterotate x   = rotate LT (rotate GT x) == x
    where _ = x :: T

prop_viewview r  x   =
    let n  = current x
        sz = size x
        i  = r `mod` sz
    in view n (view (fromIntegral i) x) == x

    where _ = x :: T

prop_shiftshift r x =
    let n  = current x
    in shift n (shift r x) == x
    where _ = x :: T

prop_fullcache x = cached == allvals where
    cached  = sort . keys $ cache x
    allvals = sort . concat . elems $ stacks x
    _       = x :: T

prop_currentwsvisible x = (current x) `elem` (visibleWorkspaces x)
    where _ = x :: T

prop_ws2screen_screen2ws x = (ws == ws') && (sc == sc')
    where ws  = sort . keys  $ ws2screen x
          ws' = sort . elems $ screen2ws x
          sc  = sort . keys  $ screen2ws x
          sc' = sort . elems $ ws2screen x
          _ = x :: T

prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)]
    where test ws = case screen ws x of
                        Nothing -> True
                        Just sc -> workspace sc x == Just ws
          _ = x :: T

prop_promote2 x = promote (promote x) == (promote x)
  where _ = x :: T

prop_promotefocus x = focus (promote x) == focus x -- focus doesn't change
  where _ = x :: T

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

main :: IO ()
main = do
    args <- getArgs
    let n = if null args then 100 else read (head args)
    mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests
 where
    n = 100

    tests =
        [("read.show        ", mytest prop_id)
        ,("member/push      ", mytest prop_member1)
        ,("member/peek      ", mytest prop_peekmember)
        ,("member/delete    ", mytest prop_member2)
        ,("member/empty     ", mytest prop_member3)
        ,("size/push        ", mytest prop_sizepush)
        ,("height/push      ", mytest prop_currentpush)
        ,("push/peek        ", mytest prop_pushpeek)
        ,("delete/not.member", mytest prop_delete_uniq)
        ,("delete idempotent", mytest prop_delete2)
        ,("rotate/rotate    ", mytest prop_rotaterotate)
        ,("view/view        ", mytest prop_viewview)
        ,("fullcache        ", mytest prop_fullcache)
        ,("currentwsvisible ", mytest prop_currentwsvisible)
        ,("ws screen mapping", mytest prop_ws2screen_screen2ws)
        ,("screen/workspace ", mytest prop_screenworkspace)
        ,("promote idempotent", mytest prop_promote2)
        ,("promote/focus",     mytest prop_promotefocus)
        ]

debug = False

mytest :: Testable a => a -> Int -> IO ()
mytest a n = mycheck defaultConfig
    { configMaxTest=n
    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a

mycheck :: Testable a => Config -> a -> IO ()
mycheck config a = do
    rnd <- newStdGen
    mytests config (evaluate a) rnd 0 0 []

mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
mytests config gen rnd0 ntest nfail stamps
    | ntest == configMaxTest config = do done "OK," ntest stamps
    | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
    | otherwise               =
      do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
         case ok result of
           Nothing    ->
             mytests config gen rnd1 ntest (nfail+1) stamps
           Just True  -><commit_msg>2 more properties for promote.<commit_after>{-# OPTIONS -fglasgow-exts #-}

import StackSet

import Data.Maybe
import System.Environment
import Control.Exception    (assert)
import Control.Monad
import Test.QuickCheck hiding (promote)
import System.IO
import System.Random
import Text.Printf
import Data.List            (nub,sort,group,sort,intersperse)
import Data.Map             (keys,elems)

-- ---------------------------------------------------------------------
-- QuickCheck properties for the StackSet

-- | Height of stack 'n'
height :: WorkspaceId -> StackSet a -> Int
height i w = length (index i w)

-- build (non-empty) StackSets with between 1 and 100 stacks
instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where
    arbitrary = do
        sz <- choose (1,20)
        n  <- choose (0,sz-1)
        sc <- choose (1,sz)
        ls <- vector sz
        return $ fromList (fromIntegral n,sc,ls)
    coarbitrary = error "no coarbitrary for StackSet"

prop_id x = fromList (toList x) == x
    where _ = x :: T

prop_member1 i n m = member i (push i x)
    where x = empty n m :: T

prop_member2 i x = not (member i (delete i x))
    where _ = x :: T

prop_member3 i n m = member i (empty n m :: T) == False

prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n
    where x  = empty n m :: T

prop_currentpush is n m = n > 0 ==>
    height (current x) (foldr push x js) == length js
    where
        js = nub is
        x = empty n m :: T

prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is
    where _ = x :: T

prop_peekmember x = case peek x of
                            Just w  -> member w x
                            Nothing -> True {- then we don't know anything -}
    where _ = x :: T

type T = StackSet Int

prop_delete_uniq i x = not (member i x) ==> delete i x == x
    where _ = x :: T

prop_delete2 i x =
    delete i x == delete i (delete i x)
    where _ = x :: T

prop_rotaterotate x   = rotate LT (rotate GT x) == x
    where _ = x :: T

prop_viewview r  x   =
    let n  = current x
        sz = size x
        i  = r `mod` sz
    in view n (view (fromIntegral i) x) == x

    where _ = x :: T

prop_shiftshift r x =
    let n  = current x
    in shift n (shift r x) == x
    where _ = x :: T

prop_fullcache x = cached == allvals where
    cached  = sort . keys $ cache x
    allvals = sort . concat . elems $ stacks x
    _       = x :: T

prop_currentwsvisible x = (current x) `elem` (visibleWorkspaces x)
    where _ = x :: T

prop_ws2screen_screen2ws x = (ws == ws') && (sc == sc')
    where ws  = sort . keys  $ ws2screen x
          ws' = sort . elems $ screen2ws x
          sc  = sort . keys  $ screen2ws x
          sc' = sort . elems $ ws2screen x
          _ = x :: T

prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)]
    where test ws = case screen ws x of
                        Nothing -> True
                        Just sc -> workspace sc x == Just ws
          _ = x :: T
------------------------------------------------------------------------

-- promote is idempotent
prop_promote2 x = promote (promote x) == (promote x)
  where _ = x :: T

-- focus doesn't change
prop_promotefocus x = focus (promote x) == focus x 
  where _ = x :: T

-- screen certainly should't change
prop_promotecurrent x = current (promote x) == current x 
  where _ = x :: T

-- promote doesn't mess with other windows
prop_promoterotate x b = focus (rotate dir (promote x)) == focus (rotate dir x)
  where _ = x :: T
        dir = if b then LT else GT

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

main :: IO ()
main = do
    args <- getArgs
    let n = if null args then 100 else read (head args)
    mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests
 where
    n = 100

    tests =
        [("read.show        ", mytest prop_id)
        ,("member/push      ", mytest prop_member1)
        ,("member/peek      ", mytest prop_peekmember)
        ,("member/delete    ", mytest prop_member2)
        ,("member/empty     ", mytest prop_member3)
        ,("size/push        ", mytest prop_sizepush)
        ,("height/push      ", mytest prop_currentpush)
        ,("push/peek        ", mytest prop_pushpeek)
        ,("delete/not.member", mytest prop_delete_uniq)
        ,("delete idempotent", mytest prop_delete2)
        ,("rotate/rotate    ", mytest prop_rotaterotate)
        ,("view/view        ", mytest prop_viewview)
        ,("fullcache        ", mytest prop_fullcache)
        ,("currentwsvisible ", mytest prop_currentwsvisible)
        ,("ws screen mapping", mytest prop_ws2screen_screen2ws)
        ,("screen/workspace ", mytest prop_screenworkspace)

        ,("promote idempotent", mytest prop_promote2)
        ,("promote focus",      mytest prop_promotefocus)
        ,("promote current",    mytest prop_promotecurrent)
        ,("promote only swaps", mytest prop_promoterotate)
        ]

debug = False

mytest :: Testable a => a -> Int -> IO ()
mytest a n = mycheck defaultConfig
    { configMaxTest=n
    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a

mycheck :: Testable a => Config -> a -> IO ()
mycheck config a = do
    rnd <- newStdGen
    mytests config (evaluate a) rnd 0 0 []

mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
mytests config gen rnd0 ntest nfail stamps
    | ntest == configMaxTest config = do done "OK," ntest stamps
    | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
    | otherwise               =
      do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
         case ok result of
           Nothing    ->
             mytests config gen rnd1 ntest (nfail+1) stamps
           Just True  ->
{'fraction_non_alphanumeric': 0.13840861772426905, 'fraction_numerical': 0.00823753055128089, 'mean_word_length': 1.936735778841042, 'pattern_counts': {'":': 2, '<': 15, '<?xml version=': 0, '>': 69, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '767213', 'n_tokens_mistral': 3556, 'n_tokens_neox': 3455, 'n_words': 1263}