{-# LANGUAGE DefaultSignatures #-}
module Web.Hyperbole.Route
( Route (..)
, findRoute
, pathUrl
, routeUrl
, GenRoute (..)
, genRouteRead
, Url
) where
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Text (Text, pack, toLower, unpack)
import Data.Text qualified as T
import GHC.Generics
import Text.Read (readMaybe)
import Web.View.Types.Url (Segment, Url, pathUrl)
import Prelude hiding (dropWhile)
class Route a where
defRoute :: a
routePath :: a -> [Segment]
matchRoute :: [Segment] -> Maybe a
default matchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
matchRoute [Segment
""] = a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Route a => a
defRoute
matchRoute [] = a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Route a => a
defRoute
matchRoute [Segment]
segs = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Maybe (Rep a Any) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (Rep a Any)
forall p. [Segment] -> Maybe (Rep a p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
segs
default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> [Segment]
routePath a
p
| a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Route a => a
defRoute = []
| Bool
otherwise = (Segment -> Bool) -> [Segment] -> [Segment]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Segment -> Bool) -> Segment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> Bool
T.null) ([Segment] -> [Segment]) -> [Segment] -> [Segment]
forall a b. (a -> b) -> a -> b
$ Rep a Any -> [Segment]
forall p. Rep a p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths (Rep a Any -> [Segment]) -> Rep a Any -> [Segment]
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
p
default defRoute :: (Generic a, GenRoute (Rep a)) => a
defRoute = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to Rep a Any
forall p. Rep a p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
findRoute :: (Route a) => [Segment] -> Maybe a
findRoute :: forall a. Route a => [Segment] -> Maybe a
findRoute [] = a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Route a => a
defRoute
findRoute [Segment]
ps = [Segment] -> Maybe a
forall a. Route a => [Segment] -> Maybe a
matchRoute [Segment]
ps
routeUrl :: (Route a) => a -> Url
routeUrl :: forall a. Route a => a -> Url
routeUrl = [Segment] -> Url
pathUrl ([Segment] -> Url) -> (a -> [Segment]) -> a -> Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Segment]
forall a. Route a => a -> [Segment]
routePath
class GenRoute f where
genRoute :: [Text] -> Maybe (f p)
genPaths :: f p -> [Text]
genFirst :: f p
instance (GenRoute f) => GenRoute (M1 D c f) where
genRoute :: forall (p :: k). [Segment] -> Maybe (M1 D c f p)
genRoute [Segment]
ps = f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D c f p) -> Maybe (f p) -> Maybe (M1 D c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (f p)
forall (p :: k). [Segment] -> Maybe (f p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps
genPaths :: forall (p :: k). M1 D c f p -> [Segment]
genPaths (M1 f p
x) = f p -> [Segment]
forall (p :: k). f p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths f p
x
genFirst :: forall (p :: k). M1 D c f p
genFirst = f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
instance (Constructor c, GenRoute f) => GenRoute (M1 C c f) where
genRoute :: forall (p :: k). [Segment] -> Maybe (M1 C c f p)
genRoute (Segment
n : [Segment]
ps) = do
let name :: [Char]
name = M1 C c f Any -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName (M1 C c f x
forall (p :: k). M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f x)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Segment
n Segment -> Segment -> Bool
forall a. Eq a => a -> a -> Bool
== Segment -> Segment
toLower ([Char] -> Segment
pack [Char]
name))
f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p) -> Maybe (f p) -> Maybe (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (f p)
forall (p :: k). [Segment] -> Maybe (f p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps
genRoute [] = Maybe (M1 C c f p)
forall a. Maybe a
Nothing
genFirst :: forall (p :: k). M1 C c f p
genFirst = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
genPaths :: forall (p :: k). M1 C c f p -> [Segment]
genPaths (M1 f p
x) =
let name :: [Char]
name = M1 C c f Any -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName (M1 C c f x
forall (p :: k). M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f x)
in Segment -> Segment
toLower ([Char] -> Segment
pack [Char]
name) Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: f p -> [Segment]
forall (p :: k). f p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths f p
x
instance GenRoute U1 where
genRoute :: forall (p :: k). [Segment] -> Maybe (U1 p)
genRoute [] = U1 p -> Maybe (U1 p)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1
genRoute [Segment]
_ = Maybe (U1 p)
forall a. Maybe a
Nothing
genPaths :: forall (p :: k). U1 p -> [Segment]
genPaths U1 p
_ = []
genFirst :: forall (p :: k). U1 p
genFirst = U1 p
forall k (p :: k). U1 p
U1
instance (GenRoute f) => GenRoute (M1 S c f) where
genRoute :: forall (p :: k). [Segment] -> Maybe (M1 S c f p)
genRoute [Segment]
ps =
f p -> M1 S c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 S c f p) -> Maybe (f p) -> Maybe (M1 S c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (f p)
forall (p :: k). [Segment] -> Maybe (f p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps
genFirst :: forall (p :: k). M1 S c f p
genFirst = f p -> M1 S c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
genPaths :: forall (p :: k). M1 S c f p -> [Segment]
genPaths (M1 f p
x) = f p -> [Segment]
forall (p :: k). f p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths f p
x
instance (GenRoute a, GenRoute b) => GenRoute (a :+: b) where
genRoute :: forall (p :: k). [Segment] -> Maybe ((:+:) a b p)
genRoute [Segment]
ps = a p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a p -> (:+:) a b p) -> Maybe (a p) -> Maybe ((:+:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (a p)
forall (p :: k). [Segment] -> Maybe (a p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps Maybe ((:+:) a b p) -> Maybe ((:+:) a b p) -> Maybe ((:+:) a b p)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b p -> (:+:) a b p) -> Maybe (b p) -> Maybe ((:+:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe (b p)
forall (p :: k). [Segment] -> Maybe (b p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps
genFirst :: forall (p :: k). (:+:) a b p
genFirst = a p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 a p
forall (p :: k). a p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
genPaths :: forall (p :: k). (:+:) a b p -> [Segment]
genPaths (L1 a p
a) = a p -> [Segment]
forall (p :: k). a p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths a p
a
genPaths (R1 b p
a) = b p -> [Segment]
forall (p :: k). b p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths b p
a
instance (GenRoute a, GenRoute b) => GenRoute (a :*: b) where
genRoute :: forall (p :: k). [Segment] -> Maybe ((:*:) a b p)
genRoute (Segment
p : [Segment]
ps) = do
a p
ga <- [Segment] -> Maybe (a p)
forall (p :: k). [Segment] -> Maybe (a p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment
p]
b p
gr <- [Segment] -> Maybe (b p)
forall (p :: k). [Segment] -> Maybe (b p)
forall {k} (f :: k -> *) (p :: k).
GenRoute f =>
[Segment] -> Maybe (f p)
genRoute [Segment]
ps
(:*:) a b p -> Maybe ((:*:) a b p)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) a b p -> Maybe ((:*:) a b p))
-> (:*:) a b p -> Maybe ((:*:) a b p)
forall a b. (a -> b) -> a -> b
$ a p
ga a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
gr
genRoute [Segment]
_ = Maybe ((:*:) a b p)
forall a. Maybe a
Nothing
genFirst :: forall (p :: k). (:*:) a b p
genFirst = a p
forall (p :: k). a p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
forall (p :: k). b p
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p
genFirst
genPaths :: forall (p :: k). (:*:) a b p -> [Segment]
genPaths (a p
a :*: b p
b) = a p -> [Segment]
forall (p :: k). a p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths a p
a [Segment] -> [Segment] -> [Segment]
forall a. Semigroup a => a -> a -> a
<> b p -> [Segment]
forall (p :: k). b p -> [Segment]
forall {k} (f :: k -> *) (p :: k). GenRoute f => f p -> [Segment]
genPaths b p
b
instance (Route sub) => GenRoute (K1 R sub) where
genRoute :: forall (p :: k). [Segment] -> Maybe (K1 R sub p)
genRoute [Segment]
ts = sub -> K1 R sub p
forall k i c (p :: k). c -> K1 i c p
K1 (sub -> K1 R sub p) -> Maybe sub -> Maybe (K1 R sub p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe sub
forall a. Route a => [Segment] -> Maybe a
matchRoute [Segment]
ts
genFirst :: forall (p :: k). K1 R sub p
genFirst = sub -> K1 R sub p
forall k i c (p :: k). c -> K1 i c p
K1 sub
forall a. Route a => a
defRoute
genPaths :: forall (p :: k). K1 R sub p -> [Segment]
genPaths (K1 sub
sub) = sub -> [Segment]
forall a. Route a => a -> [Segment]
routePath sub
sub
genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a)
genRouteRead :: forall {k} x (a :: k). Read x => [Segment] -> Maybe (K1 R x a)
genRouteRead [Segment
t] = do
x -> K1 R x a
forall k i c (p :: k). c -> K1 i c p
K1 (x -> K1 R x a) -> Maybe x -> Maybe (K1 R x a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe x
forall a. Read a => [Char] -> Maybe a
readMaybe (Segment -> [Char]
unpack Segment
t)
genRouteRead [Segment]
_ = Maybe (K1 R x a)
forall a. Maybe a
Nothing
instance Route Text where
matchRoute :: [Segment] -> Maybe Segment
matchRoute [Segment
t] = Segment -> Maybe Segment
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Segment
t
matchRoute [Segment]
_ = Maybe Segment
forall a. Maybe a
Nothing
routePath :: Segment -> [Segment]
routePath Segment
t = [Segment
t]
defRoute :: Segment
defRoute = Segment
""
instance Route String where
matchRoute :: [Segment] -> Maybe [Char]
matchRoute [Segment
t] = [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment -> [Char]
unpack Segment
t)
matchRoute [Segment]
_ = Maybe [Char]
forall a. Maybe a
Nothing
routePath :: [Char] -> [Segment]
routePath [Char]
t = [[Char] -> Segment
pack [Char]
t]
defRoute :: [Char]
defRoute = [Char]
""
instance Route Integer where
matchRoute :: [Segment] -> Maybe Integer
matchRoute = [Segment] -> Maybe Integer
forall a. Read a => [Segment] -> Maybe a
matchRouteRead
routePath :: Integer -> [Segment]
routePath = Integer -> [Segment]
forall a. Show a => a -> [Segment]
routePathShow
defRoute :: Integer
defRoute = Integer
0
instance Route Int where
matchRoute :: [Segment] -> Maybe Int
matchRoute = [Segment] -> Maybe Int
forall a. Read a => [Segment] -> Maybe a
matchRouteRead
routePath :: Int -> [Segment]
routePath = Int -> [Segment]
forall a. Show a => a -> [Segment]
routePathShow
defRoute :: Int
defRoute = Int
0
instance (Route a) => Route (Maybe a) where
matchRoute :: [Segment] -> Maybe (Maybe a)
matchRoute [] = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
matchRoute [Segment]
ps = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> Maybe a
forall a. Route a => [Segment] -> Maybe a
matchRoute [Segment]
ps
routePath :: Maybe a -> [Segment]
routePath (Just a
a) = a -> [Segment]
forall a. Route a => a -> [Segment]
routePath a
a
routePath Maybe a
Nothing = []
defRoute :: Maybe a
defRoute = Maybe a
forall a. Maybe a
Nothing
matchRouteRead :: (Read a) => [Segment] -> Maybe a
matchRouteRead :: forall a. Read a => [Segment] -> Maybe a
matchRouteRead [Segment
t] = [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe (Segment -> [Char]
unpack Segment
t)
matchRouteRead [Segment]
_ = Maybe a
forall a. Maybe a
Nothing
routePathShow :: (Show a) => a -> [Segment]
routePathShow :: forall a. Show a => a -> [Segment]
routePathShow a
a = [[Char] -> Segment
pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
a)]