diff --git a/classy-miso.cabal b/classy-miso.cabal --- a/classy-miso.cabal +++ b/classy-miso.cabal @@ -1,5 +1,5 @@ name: classy-miso -version: 0.0.0.1 +version: 0.0.0.2 description: Please see the README on Github at homepage: https://github.com/RobertFischer/Classy-Miso#README.md bug-reports: https://github.com/RobertFischer/Classy-Miso#README.md @@ -26,14 +26,16 @@ hs-source-dirs: src build-depends: - base >= 4.7 && <5 - , miso >= 0.15.0.0 && < 0.16 - , rfc >= 0.0.0.25 && < 0.1 - , megaparsec >= 6.4.0.0 && < 7 - , lens >= 4.15.0.0 && < 5 - , network-uri >= 2.6.1.0 && < 2.7 - , containers >= 0.5.7.1 && < 0.6 - , url >= 2.1.3 && < 2.2 + base >= 4.7 && <5 + , miso >= 0.16.0.0 && < 0.17 + , rfc >= 0.0.0.25 && < 0.1 + , megaparsec >= 6.4.0.0 && < 7 + , lens >= 4.15.0.0 && < 5 + , network-uri >= 2.6.1.0 && < 2.7 + , containers >= 0.5.7.1 && < 0.6 + , url >= 2.1.3 && < 2.2 + , data-default >= 0.7.1.1 && < 0.8 + , transformers >= 0.5.2.0 && < 0.6 if impl(ghcjs) build-depends: aeson , bifunctors diff --git a/src/Miso/Classy.hs b/src/Miso/Classy.hs --- a/src/Miso/Classy.hs +++ b/src/Miso/Classy.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} #if !MIN_VERSION_base(4,10,0) {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif @@ -19,11 +20,13 @@ , wrapComponent , mapWrappedComponent , addSubcomponent + , initSubcomponent , WrappedAction(..) , RouteParser , ClassyEffect , WrappedEffect , ClassyTransition + , effectToTransition , ClassySub , ClassySink , WrappedView @@ -38,26 +41,35 @@ , RoutePath , actionToSub , actionToWrappedSub + , wrappedActionToSub , viewSub , viewSubs , viewSubBy , viewSubsBy , emptyView + , emptySub + , emptyWrappedSub + , fireEvent + , addEventHandler , module Miso , module Network.URI , module RFC.Miso.String + , Default(..) ) where -import Control.Lens hiding ( view ) -import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map +import Control.Lens hiding ( view ) +import Control.Monad.Trans.State.Strict ( put ) +import Control.Monad.Trans.Writer.Strict ( tell ) +import Data.Default +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map import Data.Typeable -import Miso hiding ( App (..), getCurrentURI ) -import qualified Miso.Html as Html -import Network.URI ( URI (..), parseURI ) -import qualified Network.URL as URL +import Miso hiding ( App (..), getCurrentURI ) +import qualified Miso.Html as Html +import Network.URI ( URI (..), parseURI ) +import qualified Network.URL as URL import RFC.Miso.String -import RFC.Prelude hiding ( init ) +import RFC.Prelude hiding ( init ) -- Need the ability to compare proxies for equivalence #if MIN_VERSION_base(4,10,0) @@ -66,7 +78,7 @@ eqProxy :: Proxy a -> Proxy b -> Maybe (a :~: b) eqProxy a b = eqTypeRep (typeRep a) (typeRep b) #else --- | Hand-rolled and dangerous implementation of 'eqTypeRep'. +-- | Hand-rolled and dangerous implementation of 'eqTypeRep'. BOO! eqProxy :: (Typeable a, Typeable b) => Proxy a -> Proxy b -> Maybe (a :~: b) eqProxy a b | typeRep a == typeRep b = Just undefined @@ -81,7 +93,7 @@ -- | An 'Effect' where we wrap up the action type as a 'WrappedAction'. type WrappedEffect model = Effect WrappedAction model --- | A 'Sink' where we wrap up the action type as a 'WrappedAction'. +-- | A 'Sink' where we consume the action type as a 'WrappedAction'. type WrappedSink = WrappedAction -> IO () -- | A 'Sub' where we wrap up the action type as a 'WrappedSub'. @@ -100,8 +112,8 @@ type ClassySub model = ClassySink model -> IO () -- | Wraps the concept of th e -class (Eq model, Typeable model, Typeable (Action model)) => Component model where - {-# MINIMAL init, view, subcomponents, (update|transition) #-} +class (Eq model, Typeable model, Eq (Action model), Typeable (Action model), Default(EventHandler model)) => Component model where + {-# MINIMAL init, view, eventHandlers, (update|transition) #-} -- | The actions for this component, such as those returned in an 'Effect' type Action model = action | action -> model @@ -109,22 +121,29 @@ -- | Defines the initial arguments that the component expects to receive. type InitArgs model = initargs | initargs -> model + -- | Defines the kinds of events that the parent can handle. + type EventHandler model + init :: InitArgs model → IO model -- ^ Initialize the model view :: model -> View (Action model) -- ^ Render the model into a VDOM-friendly structure + eventHandlers :: ALens' model [EventHandler model] -- ^ Holds onto all the event handlers. + subcomponents :: ALens' model [WrappedComponent] -- ^ Holds onto all the subcomponents + subcomponents = lens (const []) (const) + {-# INLINE subcomponents #-} routeParser :: model -> RouteParser -- ^ Provides a parser that defines the route for this model routeParser _ _ = fail "Model is not a route" {-# INLINE routeParser #-} -- | Implement this if you want to use the classic way to update. - update :: Action model -> model -> ClassyEffect model + update :: Action model -> model -> WrappedEffect model update = fromTransition . transition {-# INLINE update #-} -- | Implement this if you want to use the 'Transition'-based way to update. - transition :: Action model -> ClassyTransition model () + transition :: Action model -> Transition WrappedAction model () transition = toTransition . update {-# INLINE transition #-} @@ -134,13 +153,39 @@ acceptAction _ _ = True {-# INLINE acceptAction #-} +-- | Converts an 'Effect' into a 'Transition'. +effectToTransition :: Effect action model -> Transition action model () +effectToTransition (Effect model actions) = do + lift $ tell actions + put model +{-# INLINE effectToTransition #-} + +fireEvent :: (Component model) => model -> (EventHandler model -> WrappedSub) -> WrappedEffect model +fireEvent model event = Effect model $ event <$> events + where + events = model^.(cloneLens eventHandlers) +{-# INLINE fireEvent #-} + +-- | Utility method to add an 'EventHandler' instance to a 'Component'. +addEventHandler :: (Component model) => model -> EventHandler model -> model +addEventHandler model handler = model & (cloneLens eventHandlers) %~ ((:) handler) +{-# INLINE addEventHandler #-} + +addSubcomponent :: (Component parent, Component child) => parent -> child -> parent +addSubcomponent parent child = + parent & (cloneLens subcomponents) %~ ((:) $ wrapComponent child) +{-# INLINE addSubcomponent #-} + -- | Handy method for the common case when you can pass your args down to your subcomponents. -addSubcomponent :: (Component model, Component sub) => InitArgs model -> model -> (InitArgs model -> IO (InitArgs sub)) -> IO model -addSubcomponent parentArgs parent argPicker = addSub <$> (subArgs >>= init) +initSubcomponent :: (Component model, Component sub) => + InitArgs model -> model -> (InitArgs model -> IO (InitArgs sub)) -> EventHandler sub -> IO model +initSubcomponent parentArgs parent argPicker handler = addSub . addHandler <$> (subArgs >>= init) where + addHandler sub = addEventHandler sub handler subArgs = argPicker parentArgs initSubs = parent^.(cloneLens subcomponents) addSub newSub = parent & (cloneLens subcomponents) .~ (wrapComponent newSub:initSubs) +{-# INLINE initSubcomponent #-} -- | For the component itself, and then recursively for all the subcomponents, this attempts to cast -- the action (unwrapped from 'WrappedAction') to the relevant type for that component. @@ -153,7 +198,7 @@ Effect foldedModel foldedEffects = foldr foldImpl initEffect (initModel^.(cloneLens subcomponents)) foldImpl (WrappedComponent (_,subcomp)) (Effect roundModel roundEffects) = - let result = update' wrapped subcomp in + let result = update' wrapped subcomp in -- TODO Do this recursion as a scheduled IO let Effect wrappedModel wrappedEffects = result & bimap id @@ -165,7 +210,7 @@ Nothing -> noEff initModel Just myAction -> if acceptAction myAction initModel then - bimap wrapAction id $ update myAction initModel + update myAction initModel else noEff initModel {-# INLINABLE update' #-} @@ -188,7 +233,7 @@ -- | Allows you to effectively extract the component, but note that the type of the -- wrapped component can't escape its scope. -mapWrappedComponent :: (forall model. Component model => model -> a) -> WrappedComponent -> a +mapWrappedComponent :: (forall model. (Component model, Typeable model) => model -> a) -> WrappedComponent -> a mapWrappedComponent f (WrappedComponent(_,it)) = f it {-# INLINE mapWrappedComponent #-} @@ -196,6 +241,11 @@ -- hides the existential quantification. data WrappedAction = forall child. Component child => WrappedAction (Action child) +instance Eq WrappedAction where + (==) (WrappedAction left) (WrappedAction right) = + maybe False (right ==) (cast left) + {-# INLINE (==) #-} + -- | Utility function for wrapping up an action into a 'WrappedAction' wrapAction :: Component model => Action model -> WrappedAction wrapAction = WrappedAction @@ -206,6 +256,11 @@ actionToSub action sink = sink action {-# INLINE actionToSub #-} +-- | Utility method for converting a 'WrappedAction' into a 'WrappedSub' +wrappedActionToSub :: WrappedAction -> WrappedSub +wrappedActionToSub action sink = sink action +{-# INLINE wrappedActionToSub #-} + -- | Utility function for wrapping up a 'Sub' into a 'WrappedSub' wrapSub :: Component model => Sub (Action model) -> WrappedSub wrapSub sub sink = sub (sink . wrapAction) @@ -366,3 +421,13 @@ emptyView :: View anything emptyView = Html.text "" {-# INLINE emptyView #-} + +-- | An empty (nop) 'Sub' +emptySub :: Sub (Action a) +emptySub = const $ return () +{-# INLINE emptySub #-} + +-- | A wrapped version of 'emptySub' +emptyWrappedSub :: WrappedSub +emptyWrappedSub = const $ return () +{-# INLINE emptyWrappedSub #-} diff --git a/src/Miso/Classy/App.hs b/src/Miso/Classy/App.hs --- a/src/Miso/Classy/App.hs +++ b/src/Miso/Classy/App.hs @@ -12,6 +12,7 @@ , vsRoutePath , specToView , defaultSubscriptions + , applyRoute , module Miso.Classy ) where @@ -20,10 +21,9 @@ import qualified Miso import Miso.Classy import Network.URI ( URI (..), parseURI ) -import RFC.Prelude +import RFC.Prelude hiding ( init ) class (Component model) => MisoApp model where - createApp :: InitArgs model -> IO model initialAction :: model -> Action model notFoundView :: model -> WrappedComponent viewSpec :: ALens' model ViewSpec @@ -32,19 +32,6 @@ subscriptions = const defaultSubscriptions {-# INLINE subscriptions #-} -instance (MisoApp model) => HasURI model where - lensURI :: Lens' model URI - lensURI = lens - (\model -> model^.(cloneLens viewSpec) & vsUri) - (\model newUri -> model & (cloneLens viewSpec) .~ - (let theRoutePath = toRoutePath newUri in - fromMaybe - (ViewSpec (notFoundView model, theRoutePath)) - (applyRoute model theRoutePath) - ) - ) - {-# INLINE lensURI #-} - -- | These are the default subscriptions that we automatically connect to. defaultSubscriptions :: [Sub WrappedAction] defaultSubscriptions = [] @@ -79,7 +66,7 @@ -- expecting there to be a DOM in existence. startClientApp :: (MisoApp model, MonadIO m) => InitArgs model -> m () startClientApp args = liftIO $ do - app <- createApp args + app <- init args Miso.startApp $ appToRecord app {-# INLINE startClientApp #-} @@ -87,7 +74,7 @@ -- that there is an isomorphic DOM in existence already. startIsoClientApp :: (MisoApp model, MonadIO m) => InitArgs model -> m () startIsoClientApp args = liftIO $ do - app <- createApp args + app <- init args Miso.startApp $ appToRecord app {-# INLINE startIsoClientApp #-} @@ -98,10 +85,6 @@ vsRoutePath :: ViewSpec -> RoutePath vsRoutePath (ViewSpec (_,rp)) = rp {-# INLINE vsRoutePath #-} - -vsUri :: ViewSpec -> URI -vsUri (ViewSpec (_,(_,_,uri))) = uri -{-# INLINE vsUri #-} -- | Renders a view based on the viewspec specToView :: ViewSpec -> View WrappedAction