miso 0.1.5.0 → 0.2.0.0
raw patch · 4 files changed
+134/−68 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- examples/router/Main.hs +17/−10
- ghcjs-src/Miso/Router.hs +110/−56
- ghcjs-src/Miso/Subscription/History.hs +6/−1
- miso.cabal +1/−1
examples/router/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-}@@ -16,6 +17,13 @@ -- ^ current URI of application } deriving (Eq, Show) +-- | HasURI typeclass+instance HasURI Model where+ lensURI = makeLens getter setter+ where+ getter = uri+ setter = \m u -> m { uri = u }+ -- | Action data Action = HandleURI URI@@ -26,8 +34,8 @@ -- | Main entry point main :: IO () main = do- currentRoute <- getURI- startApp App { model = Model currentRoute, ..}+ currentURI <- getCurrentURI+ startApp App { model = Model currentURI, ..} where update = updateModel events = defaultEvents@@ -45,17 +53,16 @@ -- | View function, with routing viewModel :: Model -> View Action-viewModel Model {..} =- case runRoute uri (Proxy :: Proxy API) handlers of- Left _ -> the404- Right v -> v+viewModel model@Model {..} = view where+ view = either (const the404) id result+ result = runRoute (Proxy :: Proxy API) handlers model handlers = about :<|> home- home = div_ [] [+ home (_ :: Model) = div_ [] [ div_ [] [ text "home" ] , button_ [ onClick goAbout ] [ text "go about" ] ]- about = div_ [] [+ about (_ :: Model) = div_ [] [ div_ [] [ text "about" ] , button_ [ onClick goHome ] [ text "go home" ] ]@@ -65,8 +72,8 @@ ] -- | Type-level routes-type API = About :<|> Home-type Home = View Action+type API = About :<|> Home+type Home = View Action type About = "about" :> View Action -- | Type-safe links used in `onClick` event handlers to route the application
ghcjs-src/Miso/Router.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -18,8 +21,16 @@ -- Stability : experimental -- Portability : non-portable -----------------------------------------------------------------------------module Miso.Router ( runRoute, RoutingError(..) ) where+module Miso.Router+ ( runRoute+ , RoutingError (..)+ , HasURI (..)+ , getURI+ , setURI+ , makeLens+ ) where +import qualified Control.Applicative as A import qualified Data.ByteString.Char8 as BS import Data.Proxy import Data.Text (Text)@@ -31,7 +42,7 @@ import Servant.API import Web.HttpApiData -import Miso.Html hiding (text)+import Miso.Html hiding (text) -- | Router terminator. -- The 'HasRouter' instance for 'View' finalizes the router.@@ -50,7 +61,10 @@ -- Either this is an unrecoverable failure, -- such as failing to parse a query parameter, -- or it is recoverable by trying another path.-data RoutingError = Fail | FailFatal deriving (Show, Eq, Ord)+data RoutingError+ = Fail+ | FailFatal+ deriving (Show, Eq, Ord) -- | A 'Router' contains the information necessary to execute a handler. data Router a where@@ -69,59 +83,59 @@ -- It is the class responsible for making API combinators routable. -- 'RouteT' is used to build up the handler types. -- 'Router' is returned, to be interpretted by 'routeLoc'.-class HasRouter layout where+class HasRouter model layout where -- | A route handler.- type RouteT layout a :: *+ type RouteT model layout a :: * -- | Transform a route handler into a 'Router'.- route :: Proxy layout -> Proxy a -> RouteT layout a -> Router a+ route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a -- | Alternative-instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where- type RouteT (x :<|> y) a = RouteT x a :<|> RouteT y a- route _ (a :: Proxy a) ((x :: RouteT x a) :<|> (y :: RouteT y a))- = RChoice (route (Proxy :: Proxy x) a x) (route (Proxy :: Proxy y) a y)+instance (HasRouter m x, HasRouter m y) => HasRouter m (x :<|> y) where+ type RouteT m (x :<|> y) a = RouteT m x a :<|> RouteT m y a+ route _ (a :: Proxy a) ((x :: RouteT m x a) :<|> (y :: RouteT m y a)) m+ = RChoice (route (Proxy :: Proxy x) a x m) (route (Proxy :: Proxy y) a y m) -- | Capture-instance (HasRouter sublayout, FromHttpApiData x) =>- HasRouter (Capture sym x :> sublayout) where- type RouteT (Capture sym x :> sublayout) a = x -> RouteT sublayout a- route _ a f = RCapture (route (Proxy :: Proxy sublayout) a . f)+instance (HasRouter m sublayout, FromHttpApiData x) =>+ HasRouter m (Capture sym x :> sublayout) where+ type RouteT m (Capture sym x :> sublayout) a = x -> RouteT m sublayout a+ route _ a f m = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryParam-instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym)- => HasRouter (QueryParam sym x :> sublayout) where- type RouteT (QueryParam sym x :> sublayout) a = Maybe x -> RouteT sublayout a- route _ a f = RQueryParam (Proxy :: Proxy sym)- (route (Proxy :: Proxy sublayout) a . f)+instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym)+ => HasRouter m (QueryParam sym x :> sublayout) where+ type RouteT m (QueryParam sym x :> sublayout) a = Maybe x -> RouteT m sublayout a+ route _ a f m = RQueryParam (Proxy :: Proxy sym)+ (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryParams-instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym)- => HasRouter (QueryParams sym x :> sublayout) where- type RouteT (QueryParams sym x :> sublayout) a = [x] -> RouteT sublayout a- route _ a f = RQueryParams+instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym)+ => HasRouter m (QueryParams sym x :> sublayout) where+ type RouteT m (QueryParams sym x :> sublayout) a = [x] -> RouteT m sublayout a+ route _ a f m = RQueryParams (Proxy :: Proxy sym)- (route (Proxy :: Proxy sublayout) a . f)+ (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryFlag-instance (HasRouter sublayout, KnownSymbol sym)- => HasRouter (QueryFlag sym :> sublayout) where- type RouteT (QueryFlag sym :> sublayout) a = Bool -> RouteT sublayout a- route _ a f = RQueryFlag+instance (HasRouter m sublayout, KnownSymbol sym)+ => HasRouter m (QueryFlag sym :> sublayout) where+ type RouteT m (QueryFlag sym :> sublayout) a = Bool -> RouteT m sublayout a+ route _ a f m = RQueryFlag (Proxy :: Proxy sym)- (route (Proxy :: Proxy sublayout) a . f)+ (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | Path-instance (HasRouter sublayout, KnownSymbol path)- => HasRouter (path :> sublayout) where- type RouteT (path :> sublayout) a = RouteT sublayout a- route _ a page = RPath+instance (HasRouter m sublayout, KnownSymbol path)+ => HasRouter m (path :> sublayout) where+ type RouteT m (path :> sublayout) a = RouteT m sublayout a+ route _ a page m = RPath (Proxy :: Proxy path)- (route (Proxy :: Proxy sublayout) a page)+ (route (Proxy :: Proxy sublayout) a page m) -- | View-instance HasRouter (View a) where- type RouteT (View a) x = x- route _ _ = RPage+instance HasRouter m (View a) where+ type RouteT m (View a) x = m -> x+ route _ _ a m = RPage (a m) -- | Link instance HasLink (View a) where@@ -131,25 +145,29 @@ -- | Use a handler to route a 'Location'. -- Normally 'runRoute' should be used instead, unless you want custom -- handling of string failing to parse as 'URI'.-runRouteLoc :: forall layout a. HasRouter layout- => Location -> Proxy layout -> RouteT layout a -> Either RoutingError a-runRouteLoc loc layout page =- let routing = route layout (Proxy :: Proxy a) page- in routeLoc loc routing+runRouteLoc :: forall m layout a. HasRouter m layout+ => Location -> Proxy layout -> RouteT m layout a -> m -> Either RoutingError a+runRouteLoc loc layout page m =+ let routing = route layout (Proxy :: Proxy a) page m+ in routeLoc loc routing m -- | Use a handler to route a location, represented as a 'String'. -- All handlers must, in the end, return @m a@. -- 'routeLoc' will choose a route and return its result.-runRoute :: forall layout a. HasRouter layout- => URI -> Proxy layout -> RouteT layout a -> Either RoutingError a-runRoute uri layout page = runRouteLoc (uriToLocation uri) layout page+runRoute+ :: (HasURI m, HasRouter m layout)+ => Proxy layout+ -> RouteT m layout a+ -> m+ -> Either RoutingError a+runRoute layout page m = runRouteLoc (uriToLocation (getURI m)) layout page m -- | Use a computed 'Router' to route a 'Location'.-routeLoc :: Location -> Router a -> Either RoutingError a-routeLoc loc r = case r of+routeLoc :: Location -> Router a -> m -> Either RoutingError a+routeLoc loc r m = case r of RChoice a b -> do- case routeLoc loc a of- Left Fail -> routeLoc loc b+ case routeLoc loc a m of+ Left Fail -> routeLoc loc b m Left FailFatal -> Left FailFatal Right x -> Right x RCapture f -> case locPath loc of@@ -157,25 +175,25 @@ capture:paths -> case parseUrlPieceMaybe capture of Nothing -> Left FailFatal- Just x -> routeLoc loc { locPath = paths } (f x)+ Just x -> routeLoc loc { locPath = paths } (f x) m RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of- Nothing -> routeLoc loc $ f Nothing+ Nothing -> routeLoc loc (f Nothing) m Just Nothing -> Left FailFatal Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of Nothing -> Left FailFatal- Just x -> routeLoc loc $ f (Just x)- RQueryParams sym f -> maybe (Left FailFatal) (routeLoc loc . f) $ do+ Just x -> routeLoc loc (f (Just x)) m+ RQueryParams sym f -> maybe (Left FailFatal) (\x -> routeLoc loc (f x) m) $ do ps <- sequence $ snd <$> Prelude.filter (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc) sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of- Nothing -> routeLoc loc $ f False- Just Nothing -> routeLoc loc $ f True+ Nothing -> routeLoc loc (f False) m+ Just Nothing -> routeLoc loc (f True) m Just (Just _) -> Left FailFatal RPath sym a -> case locPath loc of [] -> Left Fail p:paths -> if p == T.pack (symbolVal sym)- then routeLoc (loc { locPath = paths }) a+ then routeLoc (loc { locPath = paths }) a m else Left Fail RPage a -> Right a @@ -185,3 +203,39 @@ { locPath = decodePathSegments $ BS.pack (uriPath uri) , locQuery = parseQuery $ BS.pack (uriQuery uri) }++class HasURI m where lensURI :: Lens' m URI++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+type Lens' s a = Lens s s a a+type Getting r s a = (a -> Const r a) -> (s -> Const r s)++newtype Const r a = Const { runConst :: r }+ deriving Functor++newtype Id a = Id { runId :: a }+ deriving (Functor)++instance Applicative Id where+ pure = Id+ Id f <*> Id x = Id (f x)++get :: Getting a s a -> s -> a+get l = \ s -> runConst (l Const s)++set :: Lens s t a b -> b -> s -> t+set l b = \ s -> runId (l (\ _ -> A.pure b) s)++makeLens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+makeLens get' upd = \ f s -> upd s `fmap` f (get' s)++getURI :: HasURI m => m -> URI+getURI = get lensURI++setURI :: HasURI m => URI -> m -> m+setURI m u = set lensURI m u+++++
ghcjs-src/Miso/Subscription/History.hs view
@@ -13,7 +13,7 @@ -- Portability : non-portable ---------------------------------------------------------------------------- module Miso.Subscription.History- ( getURI+ ( getCurrentURI , pushURI , replaceURI , back@@ -31,6 +31,11 @@ import Miso.String import Network.URI hiding (path) import System.IO.Unsafe++-- | Retrieves current URI of page+getCurrentURI :: IO URI+{-# INLINE getCurrentURI #-}+getCurrentURI = getURI -- | Retrieves current URI of page getURI :: IO URI
miso.cabal view
@@ -1,5 +1,5 @@ name: miso-version: 0.1.5.0+version: 0.2.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE