{-# 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)


{- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns

> data AppRoute
>  = HomePage
>  | Users
>  | User Int
>  deriving (Generic, Route)
>
> /         -> HomePage
> /users/   -> Users
> /user/100 -> User 100
-}
class Route a where
  -- | The default route to use if attempting to match on empty segments
  defRoute :: a


  -- | Map a route to segments
  routePath :: a -> [Segment]


  -- | Try to match segments to a route
  matchRoute :: [Segment] -> Maybe a
  default matchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
  -- this will match a trailing slash, but not if it is missing
  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


-- | Try to match a route, use 'defRoute' if it's empty
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


{- | Convert a 'Route' to a 'Url'

>>> routeUrl (User 100)
/user/100
-}
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


-- | Automatically derive 'Route'
class GenRoute f where
  genRoute :: [Text] -> Maybe (f p)
  genPaths :: f p -> [Text]
  genFirst :: f p


-- datatype metadata
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


-- Constructor names / lines
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
    -- take the first path off the list
    -- check that it matches the constructor name
    -- check that the rest matches
    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


-- Unary constructors
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


-- Selectors
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


-- Sum types
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


-- Product types
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)]