classy-miso 0.0.0.1 → 0.0.0.2
raw patch · 3 files changed
+109/−59 lines, 3 filesdep +data-defaultdep +transformersdep ~miso
Dependencies added: data-default, transformers
Dependency ranges changed: miso
Files
- classy-miso.cabal +11/−9
- src/Miso/Classy.hs +94/−29
- src/Miso/Classy/App.hs +4/−21
classy-miso.cabal view
@@ -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 <https://github.com/RobertFischer/Classy-Miso#README.md> 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
src/Miso/Classy.hs view
@@ -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 #-}
src/Miso/Classy/App.hs view
@@ -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