{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, DeriveAnyClass, FlexibleInstances, DeriveGeneric #-} module TestClient (testClient) where import Control.DeepSeq (NFData) import Control.Monad import Data.Monoid ((<>)) import Data.Typeable (Typeable) import Data.Maybe import Debug.Trace import GHC.Generics (Generic) import React.Flux import React.Flux.Lifecycle import React.Flux.Internal (toJSString) import React.Flux.Addons.React import React.Flux.Addons.Bootstrap import GHCJS.Types (JSVal, JSString) import GHCJS.Marshal (fromJSVal) foreign import javascript unsafe "(function(x) { \ \ if (!window.test_client_output) window.test_client_output = []; \ \ window.test_client_output.push(x); \ \})($1)" js_output :: JSString -> IO () data OutputStoreData = OutputStoreData deriving (Show, Typeable) instance StoreData OutputStoreData where type StoreAction OutputStoreData = [String] -- log both to the console and to js_output transform ss OutputStoreData = do mapM_ (js_output . toJSString) ss trace (unlines ss) $ return OutputStoreData outputStore :: ReactStore OutputStoreData outputStore = mkStore OutputStoreData output :: [String] -> [SomeStoreAction] output s = [SomeStoreAction outputStore s] outputIO :: [String] -> IO () outputIO ss = void $ transform ss OutputStoreData -------------------------------------------------------------------------------- --- Events -------------------------------------------------------------------------------- logM :: (String -> Bool) -> String logM f = "alt modifier: " ++ show (f "Alt") logT :: EventTarget -> String logT t = eventTargetProp t "id" rawShowView :: ReactView Int rawShowView = defineView "raw show view" elemShow eventsView :: ReactView () eventsView = defineView "events" $ \() -> div_ $ do p_ $ input_ [ "type" $= "text" , "id" $= "keyinput" , "placeholder" $= "onKeyDown" , onKeyDown $ \e k -> output [ "keydown" , show e , show k , logM (keyGetModifierState k) , logT (evtTarget e) , logT (evtCurrentTarget e) ] , onFocus $ \e _ -> output [ "focus" , show e --, logT $ focusRelatedTarget f ] ] p_ $ label_ [ "id" $= "clickinput" , onClick $ \e m -> output [ "click" , show e , show m , logM (mouseGetModifierState m) --, logT (mouseRelatedTarget m) ] ] "onClick" p_ $ label_ [ "id" $= "touchinput" , onTouchStart $ \e t -> output [ "touchstart" , show e , show t , logM (touchGetModifierState t) , logT (touchTarget $ head $ touchTargets t) , "endtouch" ] ] "onTouchStart" p_ $ a_ [ "id" $= "some-link" , "href" $= "http://www.haskell.org" , onClick $ \e _ -> output ["Click some-link"] ++ [preventDefault e] ] "Testing preventDefault" div_ $ div_ [ "id" $= "outer-div" , onClick $ \_ _ -> output ["Click on outer div"] , capturePhase $ onDoubleClick $ \e _ -> output ["Double click outer div"] ++ [stopPropagation e] ] $ do span_ [ "id" $= "inner-span" , onClick $ \e _ -> output ["Click inner span"] ++ [stopPropagation e] , onDoubleClick $ \_ _ -> output ["Double click inner span"] ] "Testing stopPropagation" p_ [ "id" $= "raw-show-view"] $ view rawShowView 42 mempty eventsView_ :: ReactElementM eventHandler () eventsView_ = view eventsView () mempty -------------------------------------------------------------------------------- --- Lifecycle -------------------------------------------------------------------------------- logPandS :: LPropsAndState String Int -> IO () logPandS ps = do p <- lGetProps ps st <- lGetState ps outputIO ["Current props and state: " ++ p ++ ", " ++ show st] foreign import javascript unsafe "$1.id" js_domGetId :: JSVal -> IO JSVal logDOM :: LDOM -> IO () logDOM dom = do this <- lThis dom >>= js_domGetId >>= fromJSVal x <- lRef dom "refSt" >>= js_domGetId >>= fromJSVal y <- lRef dom "refProps" >>= js_domGetId >>= fromJSVal outputIO [ "this id = " ++ fromMaybe "Nothing" this , "refStr id = " ++ fromMaybe "Nothing" x , "refProps id = " ++ fromMaybe "Nothing" y ] testLifecycle :: ReactView String testLifecycle = defineLifecycleView "testlifecycle" (12 :: Int) lifecycleConfig { lRender = \s p -> p_ ["id" $= "lifecycle-p"] $ do span_ "Current state: " span_ ["ref" $= "refSt", "id" $= "hello"] (elemShow s) span_ ["ref" $= "refProps", "id" $= "world"] $ elemText $ "Current props: " ++ p button_ [ "id" $= "increment-state" , onClick $ \_ _ st -> ([], Just $ st + 1) ] "Incr" , lComponentWillMount = Just $ \pAndS setStateFn -> do outputIO ["will mount"] logPandS pAndS setStateFn 100 , lComponentDidMount = Just $ \pAndS dom _setStateFn -> do outputIO ["did mount"] logPandS pAndS logDOM dom , lComponentWillReceiveProps = Just $ \pAndS _dom _setStateFn newProps -> do outputIO ["will recv props"] logPandS pAndS outputIO ["New props: " ++ newProps] , lComponentWillUpdate = Just $ \pAndS _dom newProps newState -> do outputIO ["will update"] logPandS pAndS outputIO ["New props: " ++ newProps, "New state: " ++ show newState] , lComponentDidUpdate = Just $ \pAndS _dom _setStateFn oldProps oldState -> do outputIO ["did update"] logPandS pAndS outputIO ["Old props: " ++ oldProps, "Old state: " ++ show oldState] , lComponentWillUnmount = Just $ \pAndS _dom -> do outputIO ["will unmount"] logPandS pAndS } testLifecycle_ :: String -> ReactElementM eventHandler () testLifecycle_ s = view testLifecycle s $ span_ ["id" $= "child-passed-to-view"] "I am a child!!!" -------------------------------------------------------------------------------- --- Children passed to view -------------------------------------------------------------------------------- displayChildren :: ReactView String displayChildren = defineView "display children" $ \ident -> span_ [classNames [("display-children", True), ("missing-name", False)], "id" @= ident] childrenPassedToView displayChildren_ :: String -> ReactElementM handler () -> ReactElementM handler () displayChildren_ = view displayChildren displayChildrenSpec :: ReactElementM handler () displayChildrenSpec = ul_ $ do li_ $ displayChildren_ "empty-children" mempty li_ $ displayChildren_ "single-child-wrapper" $ span_ ["id" $= "single-child"] "Single Child!!" li_ $ displayChildren_ "multi-child" $ span_ ["id" $= "child1"] "Child 1" <> span_ ["id" $= "child2"] "Child 2" -------------------------------------------------------------------------------- --- CSS Transitions -------------------------------------------------------------------------------- cssTransitions :: ReactView [String] cssTransitions = defineView "css transitions" $ \items -> div_ ["id" $= "css-transitions"] $ cssTransitionGroup ["transitionName" $= "example"] $ forM_ (zip items [(0 :: Int)..]) $ \(txt, key) -> div_ ["key" @= key] $ span_ ["className" $= "css-transition-entry"] $ elemText txt -------------------------------------------------------------------------------- --- Bootstrap -------------------------------------------------------------------------------- bootstrapSpec :: ReactView () bootstrapSpec = defineView "bootstrap" $ \() -> div_ ["id" $= "bootstrap"] $ do bootstrap_ "Alert" [ "bsStyle" $= "danger" , callback "onDismiss" $ output ["Closing alert"] ] $ p_ "Hello, World!" bootstrap_ "Nav" [ "activeKey" @= (1 :: Int) , callback "onSelect" $ \(i :: Int) -> output ["Switched to " ++ show i] ] $ do bootstrap_ "NavItem" ["eventKey" @= (1 :: Int)] "Item 1" bootstrap_ "NavItem" ["eventKey" @= (2 :: Int)] "Item 2" bootstrap_ "NavItem" ["eventKey" @= (3 :: Int)] "Item 3" -------------------------------------------------------------------------------- --- shouldComponentUpdate -------------------------------------------------------------------------------- data ShouldComponentUpdateData = ShouldComponentUpdateData Int String deriving (Typeable, Show) data ShouldComponentUpdateAction = IncrementAllSCUData | IncrementFirstSCUData | NoChangeToSCUData deriving (Show, Typeable, Generic, NFData) instance StoreData [ShouldComponentUpdateData] where type StoreAction [ShouldComponentUpdateData] = ShouldComponentUpdateAction transform NoChangeToSCUData s = return s transform IncrementAllSCUData d = return [ShouldComponentUpdateData (i+1) s | ShouldComponentUpdateData i s <- d] transform IncrementFirstSCUData (ShouldComponentUpdateData i s:xs) = return $ (ShouldComponentUpdateData (i+1) s) : xs transform _ [] = error "Should never happen" shouldComponentUpdateStore :: ReactStore [ShouldComponentUpdateData] shouldComponentUpdateStore = mkStore [ ShouldComponentUpdateData 1 "Hello" , ShouldComponentUpdateData 2 "World" , ShouldComponentUpdateData 3 "!!!" ] -- | This will log wheenver componentWillUpdate lifecycle event occurs logComponentWillUpdate :: ReactView ShouldComponentUpdateData logComponentWillUpdate = defineLifecycleView "shouldComponentUpdate spec" () lifecycleConfig { lRender = \() (ShouldComponentUpdateData i s) -> span_ (elemShow i) <> span_ (elemText s) , lComponentWillUpdate = Just $ \curProps _ (ShouldComponentUpdateData newI newS) () -> do ShouldComponentUpdateData curI curS <- lGetProps curProps outputIO [ "Component will update" , "current props: " ++ show curI ++ " " ++ curS , "new props: " ++ show newI ++ " " ++ newS ] } shouldComponentUpdateSpec :: ReactView () shouldComponentUpdateSpec = defineControllerView "should component update" shouldComponentUpdateStore $ \ds () -> div_ ["id" $= "should-component-update"] $ do ul_ $ forM_ (zip ds [(0 :: Int)..]) $ \(su, i) -> li_ $ viewWithKey logComponentWillUpdate i su mempty button_ ["id" $= "no-change-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore NoChangeToSCUData]] "No change to data" button_ ["id" $= "change-all-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementAllSCUData]] "Increment all" button_ ["id" $= "increment-first-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementFirstSCUData]] "Increment first entry's integer" -------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- -- | Test a lifecycle view with all lifecycle methods nothing testClient :: ReactView () testClient = defineLifecycleView "app" "Hello" lifecycleConfig { lRender = \s () -> do eventsView_ when (s /= "") $ testLifecycle_ s button_ [ "id" $= "add-app-str" , onClick $ \_ _ s' -> ([], Just $ s' ++ "o") ] "Add o" button_ [ "id" $= "clear-app-str" , onClick $ \_ _ _ -> ([], Just "") ] "Clear" displayChildrenSpec view cssTransitions ["A", "B"] mempty view bootstrapSpec () mempty view shouldComponentUpdateSpec () mempty }