{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverloadedLists #-}

module Web.Hyperbole.Route
  ( Route (..)
  , routeUri
  , GenRoute (..)
  , genMatchRoute
  , genRoutePath
  , genRouteRead
  , matchRouteRead
  , routePathShow
  , module Web.Hyperbole.Data.URI
  ) 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.Hyperbole.Data.URI
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
  = Main
  | Messages
  | User UserId
  deriving (Eq, Generic)

instance 'Route' AppRoute where
  baseRoute = Just Main
@

>>> routeUri Main
/

>>> routeUri (User 9)
/user/9
-}
class Route a where
  -- | The route to use if attempting to match an empty path
  baseRoute :: Maybe a
  default baseRoute :: (Generic a, GenRoute (Rep a)) => Maybe a
  baseRoute = Maybe a
forall a. Maybe a
Nothing


  -- | Try to match a path to a route
  matchRoute :: Path -> Maybe a
  default matchRoute :: (Generic a, GenRoute (Rep a)) => Path -> Maybe a
  -- this will match a trailing slash, but not if it is missing
  matchRoute Path
p =
    case (Path
p, Maybe a
forall a. Route a => Maybe a
baseRoute) of
      ([], Just a
b) -> a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
      (Path
_, Maybe a
_) -> [Segment] -> Maybe a
forall a. (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
genMatchRoute Path
p.segments


  -- | Map a route to a path
  routePath :: a -> Path
  default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> Path
  routePath a
p
    | a -> Maybe a
forall a. a -> Maybe a
Just a
p Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
forall a. Route a => Maybe a
baseRoute = []
    | Bool
otherwise = [Segment] -> Path
Path (a -> [Segment]
forall a. (Generic a, GenRoute (Rep a)) => a -> [Segment]
genRoutePath a
p)


genMatchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
genMatchRoute :: forall a. (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
genMatchRoute [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


genRoutePath :: (Generic a, GenRoute (Rep a)) => a -> [Segment]
genRoutePath :: forall a. (Generic a, GenRoute (Rep a)) => a -> [Segment]
genRoutePath = 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]) -> (a -> Rep a Any) -> a -> [Segment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from


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

>>> routeUri (User 100)
/user/100
-}
routeUri :: (Route a) => a -> URI
routeUri :: forall a. Route a => a -> URI
routeUri = Path -> URI
pathUri (Path -> URI) -> (a -> Path) -> a -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Path
forall a. Route a => a -> Path
routePath


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


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


-- 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 {x :: k}. M1 C c f x
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


  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 {x :: k}. M1 C c f x
forall a. HasCallStack => a
undefined :: M1 C c f x)
     in (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
$ 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
_ = []


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


  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


  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 [Item [Segment]
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


  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
<$> Path -> Maybe sub
forall a. Route a => Path -> Maybe a
matchRoute ([Segment] -> Path
Path [Segment]
ts)
  genPaths :: forall (p :: k). K1 R sub p -> [Segment]
genPaths (K1 sub
sub) = (sub -> Path
forall a. Route a => a -> Path
routePath sub
sub).segments


genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a)
genRouteRead :: forall {k} x (a :: k). Read x => [Segment] -> Maybe (K1 R x a)
genRouteRead [Item [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 Item [Segment]
Segment
t)
genRouteRead [Segment]
_ = Maybe (K1 R x a)
forall a. Maybe a
Nothing


instance Route Text where
  matchRoute :: Path -> Maybe Segment
matchRoute [Item Path
t] = Segment -> Maybe Segment
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item Path
Segment
t
  matchRoute Path
_ = Maybe Segment
forall a. Maybe a
Nothing
  routePath :: Segment -> Path
routePath Segment
t = [Item Path
Segment
t]
  baseRoute :: Maybe Segment
baseRoute = Maybe Segment
forall a. Maybe a
Nothing


instance Route String where
  matchRoute :: Path -> Maybe [Char]
matchRoute [Item Path
t] = [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment -> [Char]
unpack Item Path
Segment
t)
  matchRoute Path
_ = Maybe [Char]
forall a. Maybe a
Nothing
  routePath :: [Char] -> Path
routePath [Char]
t = [[Char] -> Segment
pack [Char]
t]
  baseRoute :: Maybe [Char]
baseRoute = Maybe [Char]
forall a. Maybe a
Nothing


instance Route Integer where
  matchRoute :: Path -> Maybe Integer
matchRoute = Path -> Maybe Integer
forall a. Read a => Path -> Maybe a
matchRouteRead
  routePath :: Integer -> Path
routePath = Integer -> Path
forall a. Show a => a -> Path
routePathShow
  baseRoute :: Maybe Integer
baseRoute = Maybe Integer
forall a. Maybe a
Nothing


instance Route Int where
  matchRoute :: Path -> Maybe Int
matchRoute = Path -> Maybe Int
forall a. Read a => Path -> Maybe a
matchRouteRead
  routePath :: Int -> Path
routePath = Int -> Path
forall a. Show a => a -> Path
routePathShow
  baseRoute :: Maybe Int
baseRoute = Maybe Int
forall a. Maybe a
Nothing


instance (Route a) => Route (Maybe a) where
  matchRoute :: Path -> 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 Path
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
<$> Path -> Maybe a
forall a. Route a => Path -> Maybe a
matchRoute Path
ps
  routePath :: Maybe a -> Path
routePath (Just a
a) = a -> Path
forall a. Route a => a -> Path
routePath a
a
  routePath Maybe a
Nothing = []
  baseRoute :: Maybe (Maybe a)
baseRoute = Maybe (Maybe a)
forall a. Maybe a
Nothing


matchRouteRead :: (Read a) => Path -> Maybe a
matchRouteRead :: forall a. Read a => Path -> Maybe a
matchRouteRead [Item Path
t] = [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe (Segment -> [Char]
unpack Item Path
Segment
t)
matchRouteRead Path
_ = Maybe a
forall a. Maybe a
Nothing


routePathShow :: (Show a) => a -> Path
routePathShow :: forall a. Show a => a -> Path
routePathShow a
a = [[Char] -> Segment
pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
a)]