{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module Miso.Router
(
Router (..)
, Capture (..)
, Path (..)
, QueryParam (..)
, QueryFlag (..)
, Token (..)
, URI (..)
, RoutingError (..)
, parseURI
, prettyURI
, prettyQueryString
, runRouter
, routes
, toQueryFlag
, toQueryParam
, toCapture
, toPath
, emptyURI
, queryFlag
, queryParam
, capture
, path
) where
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Functor
import Data.Proxy
import Data.Char
import qualified Data.Char as C
import Data.String
import Control.Applicative
import Control.Monad
import GHC.Generics
import GHC.TypeLits
import Miso.Types hiding (model)
import Miso.Util
import qualified Miso.Html.Property as P
import Miso.Util.Parser hiding (NoParses)
import qualified Miso.Util.Lexer as L
import Miso.Util.Lexer (Lexer)
import Miso.String (ToMisoString, FromMisoString, fromMisoStringEither)
import qualified Miso.String as MS
newtype Capture sym a = Capture a
deriving stock ((forall x. Capture sym a -> Rep (Capture sym a) x)
-> (forall x. Rep (Capture sym a) x -> Capture sym a)
-> Generic (Capture sym a)
forall x. Rep (Capture sym a) x -> Capture sym a
forall x. Capture sym a -> Rep (Capture sym a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (sym :: k) a x. Rep (Capture sym a) x -> Capture sym a
forall k (sym :: k) a x. Capture sym a -> Rep (Capture sym a) x
$cfrom :: forall k (sym :: k) a x. Capture sym a -> Rep (Capture sym a) x
from :: forall x. Capture sym a -> Rep (Capture sym a) x
$cto :: forall k (sym :: k) a x. Rep (Capture sym a) x -> Capture sym a
to :: forall x. Rep (Capture sym a) x -> Capture sym a
Generic, Capture sym a -> Capture sym a -> Bool
(Capture sym a -> Capture sym a -> Bool)
-> (Capture sym a -> Capture sym a -> Bool) -> Eq (Capture sym a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
$c== :: forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
== :: Capture sym a -> Capture sym a -> Bool
$c/= :: forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
/= :: Capture sym a -> Capture sym a -> Bool
Eq, Int -> Capture sym a -> ShowS
[Capture sym a] -> ShowS
Capture sym a -> [Char]
(Int -> Capture sym a -> ShowS)
-> (Capture sym a -> [Char])
-> ([Capture sym a] -> ShowS)
-> Show (Capture sym a)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall k (sym :: k) a. Show a => Int -> Capture sym a -> ShowS
forall k (sym :: k) a. Show a => [Capture sym a] -> ShowS
forall k (sym :: k) a. Show a => Capture sym a -> [Char]
$cshowsPrec :: forall k (sym :: k) a. Show a => Int -> Capture sym a -> ShowS
showsPrec :: Int -> Capture sym a -> ShowS
$cshow :: forall k (sym :: k) a. Show a => Capture sym a -> [Char]
show :: Capture sym a -> [Char]
$cshowList :: forall k (sym :: k) a. Show a => [Capture sym a] -> ShowS
showList :: [Capture sym a] -> ShowS
Show)
deriving newtype (Capture sym a -> MisoString
(Capture sym a -> MisoString) -> ToMisoString (Capture sym a)
forall str. (str -> MisoString) -> ToMisoString str
forall k (sym :: k) a.
ToMisoString a =>
Capture sym a -> MisoString
$ctoMisoString :: forall k (sym :: k) a.
ToMisoString a =>
Capture sym a -> MisoString
toMisoString :: Capture sym a -> MisoString
ToMisoString, MisoString -> Either [Char] (Capture sym a)
(MisoString -> Either [Char] (Capture sym a))
-> FromMisoString (Capture sym a)
forall t. (MisoString -> Either [Char] t) -> FromMisoString t
forall k (sym :: k) a.
FromMisoString a =>
MisoString -> Either [Char] (Capture sym a)
$cfromMisoStringEither :: forall k (sym :: k) a.
FromMisoString a =>
MisoString -> Either [Char] (Capture sym a)
fromMisoStringEither :: MisoString -> Either [Char] (Capture sym a)
FromMisoString)
newtype Path (path :: Symbol) = Path MisoString
deriving ((forall x. Path path -> Rep (Path path) x)
-> (forall x. Rep (Path path) x -> Path path)
-> Generic (Path path)
forall x. Rep (Path path) x -> Path path
forall x. Path path -> Rep (Path path) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (path :: Symbol) x. Rep (Path path) x -> Path path
forall (path :: Symbol) x. Path path -> Rep (Path path) x
$cfrom :: forall (path :: Symbol) x. Path path -> Rep (Path path) x
from :: forall x. Path path -> Rep (Path path) x
$cto :: forall (path :: Symbol) x. Rep (Path path) x -> Path path
to :: forall x. Rep (Path path) x -> Path path
Generic, Path path -> Path path -> Bool
(Path path -> Path path -> Bool)
-> (Path path -> Path path -> Bool) -> Eq (Path path)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol). Path path -> Path path -> Bool
$c== :: forall (path :: Symbol). Path path -> Path path -> Bool
== :: Path path -> Path path -> Bool
$c/= :: forall (path :: Symbol). Path path -> Path path -> Bool
/= :: Path path -> Path path -> Bool
Eq, Int -> Path path -> ShowS
[Path path] -> ShowS
Path path -> [Char]
(Int -> Path path -> ShowS)
-> (Path path -> [Char])
-> ([Path path] -> ShowS)
-> Show (Path path)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol). Int -> Path path -> ShowS
forall (path :: Symbol). [Path path] -> ShowS
forall (path :: Symbol). Path path -> [Char]
$cshowsPrec :: forall (path :: Symbol). Int -> Path path -> ShowS
showsPrec :: Int -> Path path -> ShowS
$cshow :: forall (path :: Symbol). Path path -> [Char]
show :: Path path -> [Char]
$cshowList :: forall (path :: Symbol). [Path path] -> ShowS
showList :: [Path path] -> ShowS
Show)
deriving newtype (Path path -> MisoString
(Path path -> MisoString) -> ToMisoString (Path path)
forall str. (str -> MisoString) -> ToMisoString str
forall (path :: Symbol). Path path -> MisoString
$ctoMisoString :: forall (path :: Symbol). Path path -> MisoString
toMisoString :: Path path -> MisoString
ToMisoString, [Char] -> Path path
([Char] -> Path path) -> IsString (Path path)
forall a. ([Char] -> a) -> IsString a
forall (path :: Symbol). [Char] -> Path path
$cfromString :: forall (path :: Symbol). [Char] -> Path path
fromString :: [Char] -> Path path
IsString)
newtype QueryFlag (path :: Symbol) = QueryFlag Bool
deriving ((forall x. QueryFlag path -> Rep (QueryFlag path) x)
-> (forall x. Rep (QueryFlag path) x -> QueryFlag path)
-> Generic (QueryFlag path)
forall x. Rep (QueryFlag path) x -> QueryFlag path
forall x. QueryFlag path -> Rep (QueryFlag path) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (path :: Symbol) x. Rep (QueryFlag path) x -> QueryFlag path
forall (path :: Symbol) x. QueryFlag path -> Rep (QueryFlag path) x
$cfrom :: forall (path :: Symbol) x. QueryFlag path -> Rep (QueryFlag path) x
from :: forall x. QueryFlag path -> Rep (QueryFlag path) x
$cto :: forall (path :: Symbol) x. Rep (QueryFlag path) x -> QueryFlag path
to :: forall x. Rep (QueryFlag path) x -> QueryFlag path
Generic, QueryFlag path -> QueryFlag path -> Bool
(QueryFlag path -> QueryFlag path -> Bool)
-> (QueryFlag path -> QueryFlag path -> Bool)
-> Eq (QueryFlag path)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
$c== :: forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
== :: QueryFlag path -> QueryFlag path -> Bool
$c/= :: forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
/= :: QueryFlag path -> QueryFlag path -> Bool
Eq, Int -> QueryFlag path -> ShowS
[QueryFlag path] -> ShowS
QueryFlag path -> [Char]
(Int -> QueryFlag path -> ShowS)
-> (QueryFlag path -> [Char])
-> ([QueryFlag path] -> ShowS)
-> Show (QueryFlag path)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol). Int -> QueryFlag path -> ShowS
forall (path :: Symbol). [QueryFlag path] -> ShowS
forall (path :: Symbol). QueryFlag path -> [Char]
$cshowsPrec :: forall (path :: Symbol). Int -> QueryFlag path -> ShowS
showsPrec :: Int -> QueryFlag path -> ShowS
$cshow :: forall (path :: Symbol). QueryFlag path -> [Char]
show :: QueryFlag path -> [Char]
$cshowList :: forall (path :: Symbol). [QueryFlag path] -> ShowS
showList :: [QueryFlag path] -> ShowS
Show)
newtype QueryParam (path :: Symbol) a = QueryParam (Maybe a)
deriving ((forall x. QueryParam path a -> Rep (QueryParam path a) x)
-> (forall x. Rep (QueryParam path a) x -> QueryParam path a)
-> Generic (QueryParam path a)
forall x. Rep (QueryParam path a) x -> QueryParam path a
forall x. QueryParam path a -> Rep (QueryParam path a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (path :: Symbol) a x.
Rep (QueryParam path a) x -> QueryParam path a
forall (path :: Symbol) a x.
QueryParam path a -> Rep (QueryParam path a) x
$cfrom :: forall (path :: Symbol) a x.
QueryParam path a -> Rep (QueryParam path a) x
from :: forall x. QueryParam path a -> Rep (QueryParam path a) x
$cto :: forall (path :: Symbol) a x.
Rep (QueryParam path a) x -> QueryParam path a
to :: forall x. Rep (QueryParam path a) x -> QueryParam path a
Generic, QueryParam path a -> QueryParam path a -> Bool
(QueryParam path a -> QueryParam path a -> Bool)
-> (QueryParam path a -> QueryParam path a -> Bool)
-> Eq (QueryParam path a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
$c== :: forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
== :: QueryParam path a -> QueryParam path a -> Bool
$c/= :: forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
/= :: QueryParam path a -> QueryParam path a -> Bool
Eq, Int -> QueryParam path a -> ShowS
[QueryParam path a] -> ShowS
QueryParam path a -> [Char]
(Int -> QueryParam path a -> ShowS)
-> (QueryParam path a -> [Char])
-> ([QueryParam path a] -> ShowS)
-> Show (QueryParam path a)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol) a.
Show a =>
Int -> QueryParam path a -> ShowS
forall (path :: Symbol) a. Show a => [QueryParam path a] -> ShowS
forall (path :: Symbol) a. Show a => QueryParam path a -> [Char]
$cshowsPrec :: forall (path :: Symbol) a.
Show a =>
Int -> QueryParam path a -> ShowS
showsPrec :: Int -> QueryParam path a -> ShowS
$cshow :: forall (path :: Symbol) a. Show a => QueryParam path a -> [Char]
show :: QueryParam path a -> [Char]
$cshowList :: forall (path :: Symbol) a. Show a => [QueryParam path a] -> ShowS
showList :: [QueryParam path a] -> ShowS
Show)
instance (ToMisoString a, KnownSymbol path) => ToMisoString (QueryParam path a) where
toMisoString :: QueryParam path a -> MisoString
toMisoString (QueryParam Maybe a
maybeVal) =
MisoString
-> (MisoString -> MisoString) -> Maybe MisoString -> MisoString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MisoString
forall a. Monoid a => a
mempty (\MisoString
param -> MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
param MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
val) (a -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (a -> MisoString) -> Maybe a -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
maybeVal)
where
val :: MisoString
val = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ([Char] -> MisoString) -> [Char] -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy path -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @path)
instance (FromMisoString a, KnownSymbol path) => FromMisoString (QueryParam path a) where
fromMisoStringEither :: MisoString -> Either [Char] (QueryParam path a)
fromMisoStringEither MisoString
x =
case forall t. FromMisoString t => MisoString -> Either [Char] t
fromMisoStringEither @a MisoString
x of
Right a
r -> QueryParam path a -> Either [Char] (QueryParam path a)
forall a b. b -> Either a b
Right (QueryParam path a -> Either [Char] (QueryParam path a))
-> QueryParam path a -> Either [Char] (QueryParam path a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> QueryParam path a
forall (path :: Symbol) a. Maybe a -> QueryParam path a
QueryParam (a -> Maybe a
forall a. a -> Maybe a
Just a
r)
Left [Char]
v -> [Char] -> Either [Char] (QueryParam path a)
forall a b. a -> Either a b
Left [Char]
v
instance KnownSymbol name => ToMisoString (QueryFlag name) where
toMisoString :: QueryFlag name -> MisoString
toMisoString = \case
QueryFlag Bool
True ->
MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))
QueryFlag Bool
False ->
MisoString
forall a. Monoid a => a
mempty
data Token
= QueryParamTokens [(MisoString, MisoString)]
| QueryParamToken MisoString MisoString
| QueryFlagToken MisoString
| CaptureOrPathToken MisoString
| FragmentToken MisoString
| IndexToken
deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
(Int -> Token -> ShowS)
-> (Token -> [Char]) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> [Char]
show :: Token -> [Char]
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq)
toQueryParam :: ToMisoString s => MisoString -> s -> Token
toQueryParam :: forall s. ToMisoString s => MisoString -> s -> Token
toQueryParam MisoString
k s
v = MisoString -> MisoString -> Token
QueryParamToken MisoString
k (s -> MisoString
forall str. ToMisoString str => str -> MisoString
ms s
v)
toQueryFlag :: MisoString -> Token
toQueryFlag :: MisoString -> Token
toQueryFlag = MisoString -> Token
QueryFlagToken
toCapture :: ToMisoString string => string -> Token
toCapture :: forall string. ToMisoString string => string -> Token
toCapture = MisoString -> Token
CaptureOrPathToken (MisoString -> Token) -> (string -> MisoString) -> string -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. string -> MisoString
forall str. ToMisoString str => str -> MisoString
ms
toPath :: MisoString -> Token
toPath :: MisoString -> Token
toPath = MisoString -> Token
CaptureOrPathToken
tokensToURI :: [Token] -> URI
tokensToURI :: [Token] -> URI
tokensToURI [Token]
tokens = URI
{ uriPath :: MisoString
uriPath =
case [Token]
tokens of
Token
IndexToken : [Token]
_ -> MisoString
""
[Token]
_ ->
MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"/"
[ MisoString
x
| CaptureOrPathToken MisoString
x <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isPathRelated [Token]
tokens
]
, uriQueryString :: Map MisoString (Maybe MisoString)
uriQueryString =
[Map MisoString (Maybe MisoString)]
-> Map MisoString (Maybe MisoString)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions
[ case Token
queryToken of
QueryFlagToken MisoString
k ->
MisoString -> Maybe MisoString -> Map MisoString (Maybe MisoString)
forall k a. k -> a -> Map k a
M.singleton MisoString
k Maybe MisoString
forall a. Maybe a
Nothing
QueryParamTokens [(MisoString, MisoString)]
queryParams_ ->
[(MisoString, Maybe MisoString)]
-> Map MisoString (Maybe MisoString)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ (MisoString
k, MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
v)
| (MisoString
k,MisoString
v) <- [(MisoString, MisoString)]
queryParams_
]
QueryParamToken MisoString
k MisoString
v ->
MisoString -> Maybe MisoString -> Map MisoString (Maybe MisoString)
forall k a. k -> a -> Map k a
M.singleton MisoString
k (MisoString -> Maybe MisoString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MisoString
v)
Token
_ ->
Map MisoString (Maybe MisoString)
forall a. Monoid a => a
mempty
| Token
queryToken <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isQuery [Token]
tokens
]
, uriFragment :: MisoString
uriFragment =
(Token -> MisoString) -> [Token] -> MisoString
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Token -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isFragment [Token]
tokens)
} where
isFragment :: Token -> Bool
isFragment = \case
FragmentToken{} -> Bool
True
Token
_ -> Bool
False
isQuery :: Token -> Bool
isQuery = \case
QueryFlagToken{} -> Bool
True
QueryParamToken{} -> Bool
True
Token
_ -> Bool
False
isPathRelated :: Token -> Bool
isPathRelated = \case
CaptureOrPathToken {} -> Bool
True
IndexToken {} -> Bool
True
Token
_ -> Bool
False
instance ToMisoString Token where
toMisoString :: Token -> MisoString
toMisoString = \case
CaptureOrPathToken MisoString
x -> MisoString
"/" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
x
QueryFlagToken MisoString
x -> MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
x
FragmentToken MisoString
x -> MisoString
"#" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
x
QueryParamTokens [(MisoString, MisoString)]
params ->
MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"&"
[ MisoString
key MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
value
| (MisoString
key, MisoString
value) <- [(MisoString, MisoString)]
params
]
QueryParamToken MisoString
k MisoString
v ->
MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
k MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
v
Token
IndexToken -> MisoString
"/"
data RoutingError
= ParseError MisoString [Token]
| AmbiguousParse MisoString [Token]
| LexError MisoString MisoString
| LexErrorEOF MisoString
| NoParses MisoString
deriving (Int -> RoutingError -> ShowS
[RoutingError] -> ShowS
RoutingError -> [Char]
(Int -> RoutingError -> ShowS)
-> (RoutingError -> [Char])
-> ([RoutingError] -> ShowS)
-> Show RoutingError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RoutingError -> ShowS
showsPrec :: Int -> RoutingError -> ShowS
$cshow :: RoutingError -> [Char]
show :: RoutingError -> [Char]
$cshowList :: [RoutingError] -> ShowS
showList :: [RoutingError] -> ShowS
Show, RoutingError -> RoutingError -> Bool
(RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool) -> Eq RoutingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RoutingError -> RoutingError -> Bool
== :: RoutingError -> RoutingError -> Bool
$c/= :: RoutingError -> RoutingError -> Bool
/= :: RoutingError -> RoutingError -> Bool
Eq)
type RouteParser = ParserT URI [Token] []
capture :: FromMisoString value => RouteParser value
capture :: forall value. FromMisoString value => RouteParser value
capture = do
CaptureOrPathToken capture_ <- RouteParser Token
captureOrPathToken
case fromMisoStringEither capture_ of
Left [Char]
msg -> [Char] -> ParserT URI [Token] [] value
forall a. [Char] -> ParserT URI [Token] [] a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (MisoString -> [Char]
forall a. FromMisoString a => MisoString -> a
fromMisoString ([Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms [Char]
msg))
Right value
token -> value -> ParserT URI [Token] [] value
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure value
token
path :: MisoString -> RouteParser MisoString
path :: MisoString -> RouteParser MisoString
path MisoString
specified = do
CaptureOrPathToken parsed <- RouteParser Token
captureOrPathToken
when (specified /= parsed) (fail "path")
pure specified
index :: MisoString -> RouteParser MisoString
index :: MisoString -> RouteParser MisoString
index MisoString
specified = do
Token -> RouteParser MisoString
IndexToken <- RouteParser Token
indexToken
when (specified /= "index") (fail "index")
pure "/"
parseURI :: MisoString -> Either MisoString URI
parseURI :: MisoString -> Either MisoString URI
parseURI MisoString
txt =
case MisoString -> Either LexerError [Token]
lexTokens MisoString
txt of
Left (L.LexerError MisoString
err Location
_) -> MisoString -> Either MisoString URI
forall a b. a -> Either a b
Left MisoString
err
Left (L.UnexpectedEOF Location
eof) -> MisoString -> Either MisoString URI
forall a b. a -> Either a b
Left (MisoString
"EOF: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Location -> [Char]
forall a. Show a => a -> [Char]
show Location
eof))
Right [Token]
tokens -> URI -> Either MisoString URI
forall a b. b -> Either a b
Right ([Token] -> URI
tokensToURI [Token]
tokens)
class Router route where
fromRoute :: route -> [Token]
default fromRoute :: (Generic route, GRouter (Rep route)) => route -> [Token]
fromRoute = Rep route (ZonkAny 0) -> [Token]
forall route. Rep route route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute (Rep route (ZonkAny 0) -> [Token])
-> (route -> Rep route (ZonkAny 0)) -> route -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> Rep route (ZonkAny 0)
forall x. route -> Rep route x
forall a x. Generic a => a -> Rep a x
from
toURI :: route -> URI
toURI = [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute
route :: URI -> Either RoutingError route
route = MisoString -> Either RoutingError route
forall route.
Router route =>
MisoString -> Either RoutingError route
toRoute (MisoString -> Either RoutingError route)
-> (URI -> MisoString) -> URI -> Either RoutingError route
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> MisoString
prettyURI
href_ :: route -> Attribute action
href_ = MisoString -> Attribute action
forall action. MisoString -> Attribute action
P.href_ (MisoString -> Attribute action)
-> (route -> MisoString) -> route -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> MisoString
forall route. Router route => route -> MisoString
prettyRoute
prettyRoute :: route -> MisoString
prettyRoute = URI -> MisoString
prettyURI (URI -> MisoString) -> (route -> URI) -> route -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute
dumpURI :: route -> MisoString
dumpURI = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ([Char] -> MisoString) -> (route -> [Char]) -> route -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
forall a. Show a => a -> [Char]
show (URI -> [Char]) -> (route -> URI) -> route -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute
toRoute :: MisoString -> Either RoutingError route
toRoute MisoString
input = MisoString -> RouteParser route -> Either RoutingError route
forall a. MisoString -> RouteParser a -> Either RoutingError a
parseRoute MisoString
input RouteParser route
forall route. Router route => RouteParser route
routeParser
routeParser :: RouteParser route
default routeParser :: (Generic route, GRouter (Rep route)) => RouteParser route
routeParser = Rep route (ZonkAny 1) -> route
forall a x. Generic a => Rep a x -> a
forall x. Rep route x -> route
to (Rep route (ZonkAny 1) -> route)
-> ParserT URI [Token] [] (Rep route (ZonkAny 1))
-> RouteParser route
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (Rep route (ZonkAny 1))
forall route. RouteParser (Rep route route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
runRouter :: MisoString -> RouteParser route -> Either RoutingError route
runRouter :: forall a. MisoString -> RouteParser a -> Either RoutingError a
runRouter = MisoString -> RouteParser route -> Either RoutingError route
forall a. MisoString -> RouteParser a -> Either RoutingError a
parseRoute
routes :: [ RouteParser route ] -> RouteParser route
routes :: forall route. [RouteParser route] -> RouteParser route
routes = (RouteParser route -> RouteParser route -> RouteParser route)
-> RouteParser route -> [RouteParser route] -> RouteParser route
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RouteParser route -> RouteParser route -> RouteParser route
forall a.
ParserT URI [Token] [] a
-> ParserT URI [Token] [] a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) RouteParser route
forall a. ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a
empty
prettyURI :: URI -> MisoString
prettyURI :: URI -> MisoString
prettyURI uri :: URI
uri@URI {Map MisoString (Maybe MisoString)
MisoString
uriPath :: URI -> MisoString
uriQueryString :: URI -> Map MisoString (Maybe MisoString)
uriFragment :: URI -> MisoString
uriPath :: MisoString
uriFragment :: MisoString
uriQueryString :: Map MisoString (Maybe MisoString)
..} = MisoString
"/" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
uriPath MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> URI -> MisoString
prettyQueryString URI
uri MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
uriFragment
prettyQueryString :: URI -> MisoString
prettyQueryString :: URI -> MisoString
prettyQueryString URI {Map MisoString (Maybe MisoString)
MisoString
uriPath :: URI -> MisoString
uriQueryString :: URI -> Map MisoString (Maybe MisoString)
uriFragment :: URI -> MisoString
uriPath :: MisoString
uriFragment :: MisoString
uriQueryString :: Map MisoString (Maybe MisoString)
..} = MisoString
queries MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
flags
where
queries :: MisoString
queries =
[MisoString] -> MisoString
MS.concat
[ MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>
MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"&"
[ MisoString
k MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"=" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
v
| (MisoString
k, Just MisoString
v) <- Map MisoString (Maybe MisoString)
-> [(MisoString, Maybe MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString (Maybe MisoString)
uriQueryString
]
| (Maybe MisoString -> Bool) -> [Maybe MisoString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe MisoString -> Bool
forall a. Maybe a -> Bool
isJust (Map MisoString (Maybe MisoString) -> [Maybe MisoString]
forall k a. Map k a -> [a]
M.elems Map MisoString (Maybe MisoString)
uriQueryString)
]
flags :: MisoString
flags = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
[ MisoString
"?" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
k
| (MisoString
k, Maybe MisoString
Nothing) <- Map MisoString (Maybe MisoString)
-> [(MisoString, Maybe MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString (Maybe MisoString)
uriQueryString
]
class GRouter f where
gFromRoute :: f route -> [Token]
gRouteParser :: RouteParser (f route)
instance GRouter next => GRouter (D1 m next) where
gFromRoute :: forall (route :: k). D1 m next route -> [Token]
gFromRoute (M1 next route
x) = next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
gRouteParser :: forall (route :: k). RouteParser (D1 m next route)
gRouteParser = next route -> M1 D m next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> M1 D m next route)
-> ParserT URI [Token] [] (next route)
-> ParserT URI [Token] [] (M1 D m next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
instance (KnownSymbol name, GRouter next) => GRouter (C1 (MetaCons name x y) next) where
gFromRoute :: forall (route :: k). C1 ('MetaCons name x y) next route -> [Token]
gFromRoute (M1 next route
x) =
case MisoString
name of
MisoString
"index" -> [Token
IndexToken]
MisoString
_ -> MisoString -> Token
CaptureOrPathToken MisoString
name Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
where
name :: MisoString
name = [Char] -> MisoString
lowercaseStrip ([Char] -> MisoString) -> [Char] -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
gRouteParser :: forall (route :: k).
RouteParser (C1 ('MetaCons name x y) next route)
gRouteParser = do
case MisoString
name of
MisoString
"index" -> do
RouteParser MisoString -> ParserT URI [Token] [] ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> RouteParser MisoString
index MisoString
name)
next route -> C1 ('MetaCons name x y) next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> C1 ('MetaCons name x y) next route)
-> ParserT URI [Token] [] (next route)
-> RouteParser (C1 ('MetaCons name x y) next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
MisoString
_ -> do
RouteParser MisoString -> ParserT URI [Token] [] ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> RouteParser MisoString
path MisoString
name)
next route -> C1 ('MetaCons name x y) next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> C1 ('MetaCons name x y) next route)
-> ParserT URI [Token] [] (next route)
-> RouteParser (C1 ('MetaCons name x y) next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
where
name :: MisoString
name = [Char] -> MisoString
lowercaseStrip ([Char] -> MisoString) -> [Char] -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
instance GRouter next => GRouter (S1 m next) where
gFromRoute :: forall (route :: k). S1 m next route -> [Token]
gFromRoute (M1 next route
x) = next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
gRouteParser :: forall (route :: k). RouteParser (S1 m next route)
gRouteParser = next route -> M1 S m next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> M1 S m next route)
-> ParserT URI [Token] [] (next route)
-> ParserT URI [Token] [] (M1 S m next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
instance {-# OVERLAPS #-} forall path m . KnownSymbol path => GRouter (K1 m (Path path)) where
gFromRoute :: forall (route :: k). K1 m (Path path) route -> [Token]
gFromRoute (K1 Path path
x) = Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ MisoString -> Token
CaptureOrPathToken (Path path -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Path path
x)
gRouteParser :: forall (route :: k). RouteParser (K1 m (Path path) route)
gRouteParser = Path path -> K1 m (Path path) route
forall k i c (p :: k). c -> K1 i c p
K1 (MisoString -> Path path
forall (path :: Symbol). MisoString -> Path path
Path MisoString
chunk) K1 m (Path path) route
-> RouteParser MisoString
-> ParserT URI [Token] [] (K1 m (Path path) route)
forall a b.
a -> ParserT URI [Token] [] b -> ParserT URI [Token] [] a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MisoString -> RouteParser MisoString
path MisoString
chunk
where
chunk :: MisoString
chunk = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ([Char] -> MisoString) -> [Char] -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy path -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy path
forall {k} (t :: k). Proxy t
Proxy :: Proxy path)
instance {-# OVERLAPS #-} (FromMisoString a, ToMisoString a) => GRouter (K1 m (Capture sym a)) where
gFromRoute :: forall (route :: k). K1 m (Capture sym a) route -> [Token]
gFromRoute (K1 Capture sym a
x) = Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ MisoString -> Token
CaptureOrPathToken (Capture sym a -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Capture sym a
x)
gRouteParser :: forall (route :: k). RouteParser (K1 m (Capture sym a) route)
gRouteParser = Capture sym a -> K1 m (Capture sym a) route
forall k i c (p :: k). c -> K1 i c p
K1 (Capture sym a -> K1 m (Capture sym a) route)
-> ParserT URI [Token] [] (Capture sym a)
-> ParserT URI [Token] [] (K1 m (Capture sym a) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (Capture sym a)
forall value. FromMisoString value => RouteParser value
capture
instance {-# OVERLAPS #-} forall param m a . (ToMisoString a, FromMisoString a, KnownSymbol param) =>
GRouter (K1 m (QueryParam param a)) where
gFromRoute :: forall (route :: k). K1 m (QueryParam param a) route -> [Token]
gFromRoute (K1 (QueryParam Maybe a
maybeParam)) =
case Maybe a
maybeParam of
Maybe a
Nothing -> []
Just a
v -> Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ MisoString -> MisoString -> Token
QueryParamToken ([Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Proxy param -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @param))) (a -> MisoString
forall str. ToMisoString str => str -> MisoString
ms a
v)
gRouteParser :: forall (route :: k). RouteParser (K1 m (QueryParam param a) route)
gRouteParser = QueryParam param a -> K1 m (QueryParam param a) route
forall k i c (p :: k). c -> K1 i c p
K1 (QueryParam param a -> K1 m (QueryParam param a) route)
-> ParserT URI [Token] [] (QueryParam param a)
-> ParserT URI [Token] [] (K1 m (QueryParam param a) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (QueryParam param a)
forall (param :: Symbol) a.
(FromMisoString a, KnownSymbol param) =>
RouteParser (QueryParam param a)
queryParam
queryParam
:: forall param a . (FromMisoString a, KnownSymbol param)
=> RouteParser (QueryParam param a)
queryParam :: forall (param :: Symbol) a.
(FromMisoString a, KnownSymbol param) =>
RouteParser (QueryParam param a)
queryParam = do
URI {..} <- ParserT URI [Token] [] URI
forall r token. ParserT r token [] r
askParser
QueryParam <$> do
case M.lookup (ms (symbolVal (Proxy @param))) uriQueryString of
Just (Just MisoString
value) ->
case MisoString -> Either [Char] a
forall t. FromMisoString t => MisoString -> Either [Char] t
fromMisoStringEither MisoString
value of
Left [Char]
_ -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Right a
parsed -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
parsed)
Maybe (Maybe MisoString)
_ -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
instance {-# OVERLAPS #-} forall flag m . KnownSymbol flag => GRouter (K1 m (QueryFlag flag)) where
gFromRoute :: forall (route :: k). K1 m (QueryFlag flag) route -> [Token]
gFromRoute (K1 (QueryFlag Bool
specified))
| Bool
specified = [ MisoString -> Token
QueryFlagToken MisoString
flag ]
| Bool
otherwise = []
where
flag :: MisoString
flag = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Proxy flag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @flag))
gRouteParser :: forall (route :: k). RouteParser (K1 m (QueryFlag flag) route)
gRouteParser = QueryFlag flag -> K1 m (QueryFlag flag) route
forall k i c (p :: k). c -> K1 i c p
K1 (QueryFlag flag -> K1 m (QueryFlag flag) route)
-> ParserT URI [Token] [] (QueryFlag flag)
-> ParserT URI [Token] [] (K1 m (QueryFlag flag) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (QueryFlag flag)
forall (flag :: Symbol).
KnownSymbol flag =>
RouteParser (QueryFlag flag)
queryFlag
queryFlag :: forall flag . KnownSymbol flag => RouteParser (QueryFlag flag)
queryFlag :: forall (flag :: Symbol).
KnownSymbol flag =>
RouteParser (QueryFlag flag)
queryFlag = do
URI {..} <- ParserT URI [Token] [] URI
forall r token. ParserT r token [] r
askParser
pure $ QueryFlag $ isJust (M.lookup flag uriQueryString)
where
flag :: MisoString
flag = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ([Char] -> MisoString) -> [Char] -> MisoString
forall a b. (a -> b) -> a -> b
$ Proxy flag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @flag)
instance Router a => GRouter (K1 m a) where
gFromRoute :: forall (route :: k). K1 m a route -> [Token]
gFromRoute (K1 a
x) = a -> [Token]
forall route. Router route => route -> [Token]
fromRoute a
x
gRouteParser :: forall (route :: k). RouteParser (K1 m a route)
gRouteParser = a -> K1 m a route
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 m a route)
-> ParserT URI [Token] [] a
-> ParserT URI [Token] [] (K1 m a route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] a
forall route. Router route => RouteParser route
routeParser
instance GRouter U1 where
gFromRoute :: forall (route :: k). U1 route -> [Token]
gFromRoute U1 route
U1 = []
gRouteParser :: forall (route :: k). RouteParser (U1 route)
gRouteParser = U1 route -> ParserT URI [Token] [] (U1 route)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 route
forall k (p :: k). U1 p
U1
instance (GRouter left, GRouter right) => GRouter (left :*: right) where
gFromRoute :: forall (route :: k). (:*:) left right route -> [Token]
gFromRoute (left route
left :*: right route
right) = left route -> [Token]
forall (route :: k). left route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute left route
left [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> right route -> [Token]
forall (route :: k). right route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute right route
right
gRouteParser :: forall (route :: k). RouteParser ((:*:) left right route)
gRouteParser = (left route -> right route -> (:*:) left right route)
-> ParserT URI [Token] [] (left route)
-> ParserT URI [Token] [] (right route)
-> ParserT URI [Token] [] ((:*:) left right route)
forall a b c.
(a -> b -> c)
-> ParserT URI [Token] [] a
-> ParserT URI [Token] [] b
-> ParserT URI [Token] [] c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 left route -> right route -> (:*:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) ParserT URI [Token] [] (left route)
forall (route :: k). RouteParser (left route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser ParserT URI [Token] [] (right route)
forall (route :: k). RouteParser (right route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
instance (GRouter left, GRouter right) => GRouter (left :+: right) where
gFromRoute :: forall (route :: k). (:+:) left right route -> [Token]
gFromRoute = \case
L1 left route
m1 -> left route -> [Token]
forall (route :: k). left route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute left route
m1
R1 right route
m1 -> right route -> [Token]
forall (route :: k). right route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute right route
m1
gRouteParser :: forall (route :: k). RouteParser ((:+:) left right route)
gRouteParser = (ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route))
-> ParserT URI [Token] [] ((:+:) left right route)
-> [ParserT URI [Token] [] ((:+:) left right route)]
-> ParserT URI [Token] [] ((:+:) left right route)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall a.
ParserT URI [Token] [] a
-> ParserT URI [Token] [] a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ParserT URI [Token] [] ((:+:) left right route)
forall a. ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a
empty
[ left route -> (:+:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (left route -> (:+:) left right route)
-> ParserT URI [Token] [] (left route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (left route)
forall (route :: k). RouteParser (left route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
, right route -> (:+:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (right route -> (:+:) left right route)
-> ParserT URI [Token] [] (right route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (right route)
forall (route :: k). RouteParser (right route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
]
captureOrPathToken :: RouteParser Token
captureOrPathToken :: RouteParser Token
captureOrPathToken = (Token -> Bool) -> RouteParser Token
forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy ((Token -> Bool) -> RouteParser Token)
-> (Token -> Bool) -> RouteParser Token
forall a b. (a -> b) -> a -> b
$ \case
CaptureOrPathToken {} -> Bool
True
Token
_ -> Bool
False
indexToken :: RouteParser Token
indexToken :: RouteParser Token
indexToken = (Token -> Bool) -> RouteParser Token
forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy ((Token -> Bool) -> RouteParser Token)
-> (Token -> Bool) -> RouteParser Token
forall a b. (a -> b) -> a -> b
$ \case
IndexToken {} -> Bool
True
Token
_ -> Bool
False
uriLexer :: Lexer [Token]
uriLexer :: Lexer [Token]
uriLexer = do
tokens <- Lexer Token -> Lexer [Token]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Lexer Token
lexer
void $ optional (L.char '/')
pure (postProcess tokens)
where
postProcess :: [Token] -> [Token]
postProcess :: [Token] -> [Token]
postProcess = (Token -> [Token]) -> [Token] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Token -> [Token]) -> [Token] -> [Token])
-> (Token -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ \case
QueryParamTokens [(MisoString, MisoString)]
queryParams_ ->
[ MisoString -> MisoString -> Token
QueryParamToken MisoString
k MisoString
v
| (MisoString
k,MisoString
v) <- [(MisoString, MisoString)]
queryParams_
]
Token
x -> Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
x
lexer :: Lexer Token
lexer = [Lexer Token] -> Lexer Token
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
[ Lexer Token
queryFlagLexer
, Lexer Token
captureOrPathLexer
, Lexer Token
queryParamLexer
, Lexer Token
fragmentLexer
, Lexer Token
indexLexer
] where
indexLexer :: Lexer Token
indexLexer =
Token
IndexToken Token -> Lexer Char -> Lexer Token
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
L.char Char
'/'
captureOrPathLexer :: Lexer Token
captureOrPathLexer = do
Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'/')
MisoString -> Token
CaptureOrPathToken (MisoString -> Token) -> Lexer MisoString -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer MisoString
chars
fragmentLexer :: Lexer Token
fragmentLexer = do
Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'#')
MisoString -> Token
FragmentToken (MisoString -> Token) -> Lexer MisoString -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer MisoString
chars
queryFlagLexer :: Lexer Token
queryFlagLexer = do
Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'?')
MisoString -> Token
QueryFlagToken (MisoString -> Token) -> Lexer MisoString -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer MisoString
chars
queryParamLexer :: Lexer Token
queryParamLexer = [(MisoString, MisoString)] -> Token
QueryParamTokens ([(MisoString, MisoString)] -> Token)
-> Lexer [(MisoString, MisoString)] -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'?')
Lexer Char
-> Lexer (MisoString, MisoString)
-> Lexer [(MisoString, MisoString)]
forall (m :: * -> *) sep a. Alternative m => m sep -> m a -> m [a]
sepBy (Char -> Lexer Char
L.char Char
'&') (Lexer (MisoString, MisoString)
-> Lexer [(MisoString, MisoString)])
-> Lexer (MisoString, MisoString)
-> Lexer [(MisoString, MisoString)]
forall a b. (a -> b) -> a -> b
$ do
key <- Lexer MisoString
chars
void (L.char '=')
value <- chars
pure (key, value)
chars :: Lexer MisoString
chars :: Lexer MisoString
chars = ([Char] -> MisoString) -> Lexer [Char] -> Lexer MisoString
forall a b. (a -> b) -> Lexer a -> Lexer b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Lexer [Char] -> Lexer MisoString)
-> (Lexer Char -> Lexer [Char]) -> Lexer Char -> Lexer MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Char -> Lexer [Char]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Lexer Char -> Lexer MisoString) -> Lexer Char -> Lexer MisoString
forall a b. (a -> b) -> a -> b
$ do
(Char -> Bool) -> Lexer Char
L.satisfy ((Char -> Bool) -> Lexer Char) -> (Char -> Bool) -> Lexer Char
forall a b. (a -> b) -> a -> b
$ \Char
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ Char -> Bool
isAlphaNum Char
x
, Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
, Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
, Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'~'
, Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%'
, Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
]
lexTokens :: MisoString -> Either L.LexerError [Token]
lexTokens :: MisoString -> Either LexerError [Token]
lexTokens MisoString
input =
case Lexer [Token] -> Stream -> Either LexerError ([Token], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
L.runLexer Lexer [Token]
uriLexer (MisoString -> Stream
L.mkStream MisoString
input) of
Right ([Token]
tokens, Stream
_) -> [Token] -> Either LexerError [Token]
forall a b. b -> Either a b
Right [Token]
tokens
Left LexerError
x -> LexerError -> Either LexerError [Token]
forall a b. a -> Either a b
Left LexerError
x
parseRoute :: MisoString -> RouteParser a -> Either RoutingError a
parseRoute :: forall a. MisoString -> RouteParser a -> Either RoutingError a
parseRoute MisoString
input RouteParser a
parser =
case Lexer [Token] -> Stream -> Either LexerError ([Token], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
L.runLexer Lexer [Token]
uriLexer (MisoString -> Stream
L.mkStream MisoString
input) of
Left (L.LexerError MisoString
lexErrorMessage Location
_) ->
RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (MisoString -> MisoString -> RoutingError
LexError MisoString
input MisoString
lexErrorMessage)
Left (L.UnexpectedEOF Location
_) ->
RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (MisoString -> RoutingError
LexErrorEOF MisoString
input)
Right ([Token]
tokens, Stream
_) -> do
let
uri :: URI
uri = [Token] -> URI
tokensToURI [Token]
tokens
isCapturePathOrIndex :: Token -> Bool
isCapturePathOrIndex = \case
CaptureOrPathToken{} -> Bool
True
IndexToken{} -> Bool
True
Token
_ -> Bool
False
case RouteParser a -> URI -> [Token] -> [(a, [Token])]
forall r token (m :: * -> *) a.
ParserT r token m a -> r -> token -> m (a, token)
runParserT RouteParser a
parser URI
uri ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isCapturePathOrIndex [Token]
tokens) of
[(a
x, [])] ->
a -> Either RoutingError a
forall a b. b -> Either a b
Right a
x
[(a
_, [Token]
leftovers)] ->
RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ MisoString -> [Token] -> RoutingError
ParseError MisoString
input [Token]
leftovers
[] ->
RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ MisoString -> RoutingError
NoParses MisoString
input
(a
_, [Token]
leftovers) : [(a, [Token])]
_ ->
RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ MisoString -> [Token] -> RoutingError
AmbiguousParse MisoString
input [Token]
leftovers
lowercaseStrip :: String -> MisoString
lowercaseStrip :: [Char] -> MisoString
lowercaseStrip (Char
x:[Char]
xs) = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Char -> Char
C.toLower Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
C.isLower [Char]
xs)
lowercaseStrip [Char]
x = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
ms [Char]
x
data URI
= URI
{ URI -> MisoString
uriPath, URI -> MisoString
uriFragment :: MisoString
, URI -> Map MisoString (Maybe MisoString)
uriQueryString :: M.Map MisoString (Maybe MisoString)
} deriving (Int -> URI -> ShowS
[URI] -> ShowS
URI -> [Char]
(Int -> URI -> ShowS)
-> (URI -> [Char]) -> ([URI] -> ShowS) -> Show URI
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> URI -> ShowS
showsPrec :: Int -> URI -> ShowS
$cshow :: URI -> [Char]
show :: URI -> [Char]
$cshowList :: [URI] -> ShowS
showList :: [URI] -> ShowS
Show, URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
/= :: URI -> URI -> Bool
Eq)
emptyURI :: URI
emptyURI :: URI
emptyURI = MisoString
-> MisoString -> Map MisoString (Maybe MisoString) -> URI
URI MisoString
forall a. Monoid a => a
mempty MisoString
forall a. Monoid a => a
mempty Map MisoString (Maybe MisoString)
forall a. Monoid a => a
mempty
instance ToMisoString URI where
toMisoString :: URI -> MisoString
toMisoString = URI -> MisoString
prettyURI