diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE BangPatterns #-} module Main where +import Data.Bool import Data.Function import qualified Data.Map as M import Data.Monoid @@ -20,6 +21,9 @@ foreign import javascript unsafe "$r = performance.now();" now :: IO Double +spriteFrames :: [MisoString] +spriteFrames = ["0 0", "-74px 0","-111px 0","-148px 0","-185px 0","-222px 0","-259px 0","-296px 0"] + main :: IO () main = do time <- now @@ -113,32 +117,33 @@ display m@Model{..} = marioImage where (h,w) = window - verb = if | y > 0 -> "jump" - | vx /= 0 -> "walk" - | otherwise -> "stand" - d = case dir of - L -> "left" - R -> "right" - src = "imgs/"<> verb <> "/" <> d <> ".gif" groundY = 62 - (fromIntegral (fst window) / 2) marioImage = div_ [ height_ $ pack (show h) - , height_ $ pack (show w) - ] [ img_ [ height_ "37" - , width_ "37" - , src_ src - , style_ (marioStyle m groundY) - ] [] ] + , width_ $ pack (show w) + ] [ div_ [ style_ (marioStyle m groundY) ] [] ] marioStyle :: Model -> Double -> M.Map MisoString MisoString marioStyle Model {..} gy = - M.fromList [ ("transform", matrix x $ abs (y + gy) ) + M.fromList [ ("transform", matrix dir x $ abs (y + gy) ) , ("display", "block") + , ("width", "37px") + , ("height", "37px") + , ("background-color", "transparent") + , ("background-image", "url(imgs/mario.png)") + , ("background-repeat", "no-repeat") + , ("background-position", spriteFrames !! frame) + , bool mempty ("animation", "play 0.8s steps(8) infinite") (y == 0 && vx /= 0) ] + where + frame | y > 0 = 1 + | otherwise = 0 -matrix :: Double -> Double -> MisoString -matrix x y = - "matrix(1,0,0,1," +matrix :: Direction -> Double -> Double -> MisoString +matrix dir x y = + "matrix(" + <> (if dir == L then "-1" else "1") + <> ",0,0,1," <> pack (show x) <> "," <> pack (show y) diff --git a/examples/mario/imgs/jump/left.gif b/examples/mario/imgs/jump/left.gif deleted file mode 100644 Binary files a/examples/mario/imgs/jump/left.gif and /dev/null differ diff --git a/examples/mario/imgs/jump/right.gif b/examples/mario/imgs/jump/right.gif deleted file mode 100644 Binary files a/examples/mario/imgs/jump/right.gif and /dev/null differ diff --git a/examples/mario/imgs/mario.png b/examples/mario/imgs/mario.png new file mode 100644 Binary files /dev/null and b/examples/mario/imgs/mario.png differ diff --git a/examples/mario/imgs/stand/left.gif b/examples/mario/imgs/stand/left.gif deleted file mode 100644 Binary files a/examples/mario/imgs/stand/left.gif and /dev/null differ diff --git a/examples/mario/imgs/stand/right.gif b/examples/mario/imgs/stand/right.gif deleted file mode 100644 Binary files a/examples/mario/imgs/stand/right.gif and /dev/null differ diff --git a/examples/mario/imgs/walk/left.gif b/examples/mario/imgs/walk/left.gif deleted file mode 100644 Binary files a/examples/mario/imgs/walk/left.gif and /dev/null differ diff --git a/examples/mario/imgs/walk/right.gif b/examples/mario/imgs/walk/right.gif deleted file mode 100644 Binary files a/examples/mario/imgs/walk/right.gif and /dev/null differ diff --git a/examples/mario/index.html b/examples/mario/index.html new file mode 100644 --- /dev/null +++ b/examples/mario/index.html @@ -0,0 +1,12 @@ + + + + + + + + + + diff --git a/ghcjs-src/Miso/Router.hs b/ghcjs-src/Miso/Router.hs deleted file mode 100644 --- a/ghcjs-src/Miso/Router.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Router --- Copyright : (C) 2016-2017 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Router - ( runRoute - , RoutingError (..) - , HasURI (..) - , getURI - , setURI - , makeLens - ) where - -import qualified Data.ByteString.Char8 as BS -import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding -import GHC.TypeLits -import Network.HTTP.Types -import Network.URI -import Servant.API -import Web.HttpApiData - -import Miso.Html hiding (text) -import Miso.Lens - --- | Router terminator. --- The 'HasRouter' instance for 'View' finalizes the router. --- --- Example: --- --- > type MyApi = "books" :> Capture "bookId" Int :> View - --- | 'Location' is used to split the path and query of a URI into components. -data Location = Location - { locPath :: [Text] - , locQuery :: Query - } deriving (Show, Eq, Ord) - --- | When routing, the router may fail to match a location. --- 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) - --- | A 'Router' contains the information necessary to execute a handler. -data Router a where - RChoice :: Router a -> Router a -> Router a - RCapture :: FromHttpApiData x => (x -> Router a) -> Router a - RQueryParam :: (FromHttpApiData x, KnownSymbol sym) - => Proxy sym -> (Maybe x -> Router a) -> Router a - RQueryParams :: (FromHttpApiData x, KnownSymbol sym) - => Proxy sym -> ([x] -> Router a) -> Router a - RQueryFlag :: KnownSymbol sym - => Proxy sym -> (Bool -> Router a) -> Router a - RPath :: KnownSymbol sym => Proxy sym -> Router a -> Router a - RPage :: a -> Router a - --- | This is similar to the @HasServer@ class from @servant-server@. --- 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 model layout where - -- | A route handler. - type RouteT model layout a :: * - -- | Transform a route handler into a 'Router'. - route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a - --- | Alternative -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 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 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 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) - (\x -> route (Proxy :: Proxy sublayout) a (f x) m) - --- | QueryFlag -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) - (\x -> route (Proxy :: Proxy sublayout) a (f x) m) - --- | Path -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 m) - --- | View -instance HasRouter m (View a) where - type RouteT m (View a) x = m -> x - route _ _ a m = RPage (a m) - --- | 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 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 - :: (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 -> m -> Either RoutingError a -routeLoc loc r m = case r of - RChoice a b -> do - 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 - [] -> Left Fail - capture:paths -> - case parseUrlPieceMaybe capture of - Nothing -> Left FailFatal - 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) m - Just Nothing -> Left FailFatal - Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of - Nothing -> Left FailFatal - 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) 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 m - else Left Fail - RPage a -> - case locPath loc of - [] -> Right a - _ -> Left Fail - --- | Convert a 'URI' to a 'Location'. -uriToLocation :: URI -> Location -uriToLocation uri = Location - { locPath = decodePathSegments $ BS.pack (uriPath uri) - , locQuery = parseQuery $ BS.pack (uriQuery uri) - } - -class HasURI m where lensURI :: Lens' m URI - -getURI :: HasURI m => m -> URI -getURI = get lensURI - -setURI :: HasURI m => URI -> m -> m -setURI m u = set lensURI m u - - - - - diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.8.0.0 +version: 0.9.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE @@ -18,12 +18,8 @@ README.md examples/todo-mvc/index.html examples/websocket/index.html - examples/mario/imgs/jump/right.gif - examples/mario/imgs/jump/left.gif - examples/mario/imgs/stand/right.gif - examples/mario/imgs/stand/left.gif - examples/mario/imgs/walk/right.gif - examples/mario/imgs/walk/left.gif + examples/mario/index.html + examples/mario/imgs/mario.png flag examples default: @@ -259,6 +255,7 @@ Miso.Event Miso.Event.Decoder Miso.Event.Types + Miso.Router Miso.Svg Miso.Svg.Attribute Miso.Svg.Element @@ -276,6 +273,9 @@ base < 5, bytestring, containers, + http-api-data, + http-types, + network-uri, servant, text, transformers @@ -284,9 +284,6 @@ ghcjs-src build-depends: ghcjs-base, - http-types, - network-uri, - http-api-data, containers, scientific, unordered-containers, @@ -303,7 +300,6 @@ Miso.Effect.Storage Miso.Effect.XHR Miso.Effect.DOM - Miso.Router Miso.Subscription Miso.Subscription.History Miso.Subscription.Keyboard diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Router.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.Router +-- Copyright : (C) 2016-2017 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- +module Miso.Router + ( runRoute + , RoutingError (..) + , HasURI (..) + , getURI + , setURI + , makeLens + ) where + +import qualified Data.ByteString.Char8 as BS +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import GHC.TypeLits +import Network.HTTP.Types +import Network.URI +import Servant.API +import Web.HttpApiData + +import Miso.Html hiding (text) +import Miso.Lens + +-- | Router terminator. +-- The 'HasRouter' instance for 'View' finalizes the router. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "bookId" Int :> View + +-- | 'Location' is used to split the path and query of a URI into components. +data Location = Location + { locPath :: [Text] + , locQuery :: Query + } deriving (Show, Eq, Ord) + +-- | When routing, the router may fail to match a location. +-- 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) + +-- | A 'Router' contains the information necessary to execute a handler. +data Router a where + RChoice :: Router a -> Router a -> Router a + RCapture :: FromHttpApiData x => (x -> Router a) -> Router a + RQueryParam :: (FromHttpApiData x, KnownSymbol sym) + => Proxy sym -> (Maybe x -> Router a) -> Router a + RQueryParams :: (FromHttpApiData x, KnownSymbol sym) + => Proxy sym -> ([x] -> Router a) -> Router a + RQueryFlag :: KnownSymbol sym + => Proxy sym -> (Bool -> Router a) -> Router a + RPath :: KnownSymbol sym => Proxy sym -> Router a -> Router a + RPage :: a -> Router a + +-- | This is similar to the @HasServer@ class from @servant-server@. +-- 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 model layout where + -- | A route handler. + type RouteT model layout a :: * + -- | Transform a route handler into a 'Router'. + route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a + +-- | Alternative +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 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 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 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) + (\x -> route (Proxy :: Proxy sublayout) a (f x) m) + +-- | QueryFlag +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) + (\x -> route (Proxy :: Proxy sublayout) a (f x) m) + +-- | Path +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 m) + +-- | View +instance HasRouter m (View a) where + type RouteT m (View a) x = m -> x + route _ _ a m = RPage (a m) + +-- | 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 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 + :: (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 -> m -> Either RoutingError a +routeLoc loc r m = case r of + RChoice a b -> do + 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 + [] -> Left Fail + capture:paths -> + case parseUrlPieceMaybe capture of + Nothing -> Left FailFatal + 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) m + Just Nothing -> Left FailFatal + Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of + Nothing -> Left FailFatal + 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) 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 m + else Left Fail + RPage a -> + case locPath loc of + [] -> Right a + _ -> Left Fail + +-- | Convert a 'URI' to a 'Location'. +uriToLocation :: URI -> Location +uriToLocation uri = Location + { locPath = decodePathSegments $ BS.pack (uriPath uri) + , locQuery = parseQuery $ BS.pack (uriQuery uri) + } + +class HasURI m where lensURI :: Lens' m URI + +getURI :: HasURI m => m -> URI +getURI = get lensURI + +setURI :: HasURI m => URI -> m -> m +setURI m u = set lensURI m u + + + + +