{-# LANGUAGE RecordWildCards #-} module Potato.Flow.Common where import Relude hiding (empty, fromList, first) import Test.HUnit import Reflex import Reflex.Test.Host import Potato.Flow import Potato.Flow.DebugHelpers import qualified Data.IntMap as IM import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.These -- generic testing data GoatWidgetCmd = EWCMouse LMouseData | EWCKeyboard KeyboardData | EWCTool Tool | EWCSetParams ControllersWithId | EWCLoad (SPotatoFlow, ControllerMeta) | EWCNothing | EWCLabel Text | EWCCanvasResize XY | EWCNewFolder | EWCMarkSaved | EWCScreenRegion XY everything_network_app :: forall t m. (t ~ SpiderTimeline Global, m ~ SpiderHost Global) => OwlPFState -> ControllerMeta -> AppIn t () GoatWidgetCmd -> TestGuestT t m (AppOut t GoatState GoatState) everything_network_app pfs cm (AppIn _ ev) = do let ewc = GoatWidgetConfig { -- TODO pass in actual ControllerMeta _goatWidgetConfig_initialState = (pfs, cm) , _goatWidgetConfig_load = fforMaybe ev $ \case EWCLoad x -> Just x _ -> Nothing , _goatWidgetConfig_setDebugLabel = fforMaybe ev $ \case EWCLabel x -> Just x _ -> Nothing , _goatWidgetConfig_mouse = fforMaybe ev $ \case EWCMouse x -> Just x _ -> Nothing , _goatWidgetConfig_keyboard = fforMaybe ev $ \case EWCKeyboard x -> Just x _ -> Nothing , _goatWidgetConfig_selectTool = fforMaybe ev $ \case EWCTool x -> Just x _ -> Nothing , _goatWidgetConfig_paramsEvent = fforMaybe ev $ \case EWCSetParams x -> Just (makePFCLlama $ OwlPFCManipulate x) _ -> Nothing , _goatWidgetConfig_canvasSize = fforMaybe ev $ \case EWCCanvasResize x -> Just x _ -> Nothing , _goatWidgetConfig_newFolder = fforMaybe ev $ \case EWCNewFolder -> Just () _ -> Nothing , _goatWidgetConfig_setPotatoDefaultParameters = never , _goatWidgetConfig_markSaved = fforMaybe ev $ \case EWCMarkSaved -> Just () _ -> Nothing , _goatWidgetConfig_bypassEvent = never , _goatWidgetConfig_canvasRegionDim = fforMaybe ev $ \case EWCScreenRegion x -> Just x _ -> Nothing , _goatWidgetConfig_unicodeWidthFn = Nothing , _goatWidgetConfig_setFocusedArea = never } everythingWidget <- holdGoatWidget ewc let rDyn = _goatWidget_DEBUG_goatState everythingWidget return $ AppOut (current rDyn) (updated rDyn) data EverythingPredicate where EqPredicate :: (Show a, Eq a) => (GoatState -> a) -> a -> EverythingPredicate FunctionPredicate :: (GoatState -> (Text, Bool)) -> EverythingPredicate PFStateFunctionPredicate :: (OwlPFState -> (Text, Bool)) -> EverythingPredicate AlwaysPass :: EverythingPredicate LabelCheck :: Text -> EverythingPredicate Combine :: [EverythingPredicate] -> EverythingPredicate testEverythingPredicate :: EverythingPredicate -> GoatState -> Bool testEverythingPredicate (EqPredicate f a) e = f e == a testEverythingPredicate (FunctionPredicate f) e = snd $ f e testEverythingPredicate (PFStateFunctionPredicate f) e = snd . f $ goatState_pFState e testEverythingPredicate AlwaysPass _ = True -- TODO actually set a label and pipe it through EverythingCombined_DEBUG? testEverythingPredicate (LabelCheck l) e = l == _goatState_debugLabel e testEverythingPredicate (Combine xs) e = all id . map (\p -> testEverythingPredicate p e) $ xs showEverythingPredicate :: EverythingPredicate -> GoatState -> Text showEverythingPredicate (EqPredicate f a) e = "expected: " <> show a <> " got: " <> show (f e) showEverythingPredicate (FunctionPredicate f) e = fst $ f e showEverythingPredicate (PFStateFunctionPredicate f) e = fst . f $ goatState_pFState e showEverythingPredicate AlwaysPass _ = "always pass" -- TODO actually set a label and pipe it through EverythingCombined_DEBUG? showEverythingPredicate (LabelCheck l) e = "expected label: " <> show l <> " got: " <> show (_goatState_debugLabel e) -- TODO this should not print passing tests as well :( showEverythingPredicate (Combine xs) e = "[" <> foldr (\p acc -> showEverythingPredicate p e <> ", " <> acc) "" xs <> "]" checkNumElts :: Int -> OwlPFState -> (Text, Bool) checkNumElts n OwlPFState {..} = (t,r) where ds = IM.size (_owlTree_mapping _owlPFState_owlTree) r = ds == n t = "expected: " <> show n <> " owlTree: " <> show ds numEltsInLBoxUsingBroadphasePredicate :: Int -> LBox -> EverythingPredicate numEltsInLBoxUsingBroadphasePredicate n lbox = FunctionPredicate $ (\(BroadPhaseState bps) -> let gotn = length $ broadPhase_cull lbox bps in ("BroadPhase passed: " <> show gotn <> " expected: " <> show n <> " broadphase: " <> show bps, gotn == n)) . _goatState_broadPhaseState numSelectedEltsEqualPredicate :: Int -> EverythingPredicate numSelectedEltsEqualPredicate n = FunctionPredicate $ (\s -> let nSelected = Seq.length s in ("Selected: " <> show nSelected <> " expected: " <> show n, nSelected == n)) . unSuperOwlParliament . _goatState_selection -- you can prob delete this, better to always check for state using version below checkHandlerName :: Text -> EverythingPredicate checkHandlerName name = FunctionPredicate $ (\(SomePotatoHandler h) -> let hName = pHandlerName h in ("Handler: " <> hName <> " expected: " <> name, hName == name)) . _goatState_handler checkHandlerNameAndState :: Text -> Bool -> EverythingPredicate checkHandlerNameAndState name st = FunctionPredicate $ (\(SomePotatoHandler h) -> let hName = pHandlerName h hst = pIsHandlerActive h in ("Handler: " <> hName <> "(" <> show hst <> ") expected: " <> name <> " (" <> show st <> ")", hName == name && hst == st)) . _goatState_handler firstSelectedSuperOwlWithOwlTreePredicate :: Maybe Text -> (OwlTree -> SuperOwl -> Bool) -> EverythingPredicate firstSelectedSuperOwlWithOwlTreePredicate mlabel f = FunctionPredicate fn where fn GoatState {..} = r where s = unSuperOwlParliament _goatState_selection owltree = _owlPFState_owlTree $ _owlPFWorkspace_owlPFState _goatState_workspace mfirst = case mlabel of Nothing -> Seq.lookup 0 s Just label -> find (\sowl -> hasOwlItem_name sowl == label) s r = case mfirst of Nothing -> ("No elt with label " <> show mlabel <> show (fmap hasOwlItem_name s), False) Just first -> ("First selected: " <> show first, f owltree first) firstSelectedSuperOwlPredicate :: Maybe Text -> (SuperOwl -> Bool) -> EverythingPredicate firstSelectedSuperOwlPredicate mlabel f = firstSelectedSuperOwlWithOwlTreePredicate mlabel (\_ sowl -> f sowl) firstSuperOwlPredicate :: Maybe Text -> (SuperOwl -> Bool) -> EverythingPredicate firstSuperOwlPredicate mlabel f = FunctionPredicate $ (\ot -> let sowls = toList $ owliterateall ot mfirst = case mlabel of Nothing -> case sowls of [] -> Nothing x:_ -> Just x Just label -> case find (\sowl -> hasOwlItem_name sowl == label) sowls of Nothing -> Nothing Just sowl -> Just sowl in case mfirst of Nothing -> ("No elt with label " <> show mlabel, False) Just first -> ("First elt with label " <> show mlabel <> ": " <> show first, f first)) . _owlPFState_owlTree . goatState_pFState constructTestWithControllerMeta :: String -> OwlPFState -> ControllerMeta -> [GoatWidgetCmd] -> [EverythingPredicate] -> Test constructTestWithControllerMeta label pfs cm bs expected = TestLabel label $ TestCase $ do let run = runApp (everything_network_app pfs cm) () (fmap (Just . That) bs) values :: [[(GoatState, Maybe GoatState)]] <- liftIO run -- expect only 1 tick per event forM values $ \x -> assertEqual "expect only 1 tick per event" (length x) 1 -- expect correct number of outputs assertEqual "expect correct number of outputs" (length values) (length expected) -- TODO do index counting from labels -- expect each output matches predicate -- if no output event, uses output behavior to test predicate forM_ (zip3 (join values) expected [(0::Int)..]) $ \((b, me), p, i) -> let testfn ewcd = (assertBool . T.unpack) ((showEverythingPredicate p ewcd) <> " \n[label = " <> _goatState_debugLabel ewcd <> ", index = " <> show i <> "]" <> "\ntree = " <> case me of Just e -> (potatoShow . _owlPFState_owlTree . goatState_pFState $ e) Nothing -> (potatoShow . _owlPFState_owlTree . goatState_pFState $ b)) {-<> "\nstate = " <> case me of Just e -> show (goatState_pFState e) Nothing -> show (goatState_pFState b))-} (testEverythingPredicate p ewcd) in case me of Just e -> testfn e Nothing -> testfn b constructTest :: String -> OwlPFState -> [GoatWidgetCmd] -> [EverythingPredicate] -> Test constructTest label pfs bs expected = constructTestWithControllerMeta label pfs emptyControllerMeta bs expected -- partial function to get SAutoLine hasOwlItem_test_toSAutoLine :: (HasOwlItem a) => a -> SAutoLine hasOwlItem_test_toSAutoLine o = case hasOwlItem_toSElt_hack o of SEltLine ssline -> ssline selt -> error $ "expected SAutoLine, got " <> show selt