{-# LANGUAGE DefaultSignatures #-}

module Web.Hyperbole.Route where

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.String (IsString (..))
import Data.Text (Text, dropWhile, dropWhileEnd, intercalate, pack, splitOn, toLower, unpack)
import GHC.Generics
import Text.Read (readMaybe)
import Web.View.Types (Url (..))
import Prelude hiding (dropWhile)


type IsAbsolute = Bool
type Segment = Text
data Path = Path
  { Path -> Bool
isAbsolute :: Bool
  , Path -> [Segment]
segments :: [Segment]
  }
  deriving (Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> String
show :: Path -> String
$cshowList :: [Path] -> ShowS
showList :: [Path] -> ShowS
Show)


-- what if you want a relative url?
instance IsString Path where
  fromString :: String -> Path
fromString String
s = Bool -> [Segment] -> Path
Path (String -> Bool
isRoot String
s) [Segment -> Segment
cleanSegment (Segment -> Segment) -> Segment -> Segment
forall a b. (a -> b) -> a -> b
$ String -> Segment
pack String
s]
   where
    isRoot :: String -> Bool
isRoot (Char
'/' : String
_) = Bool
True
    isRoot String
_ = Bool
False


class Route a where
  matchRoute :: Path -> Maybe a
  routePath :: a -> Path
  defRoute :: 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 Bool
_ [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 (Path Bool
_ [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 -> Path
  routePath a
p
    | a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Route a => a
defRoute = Bool -> [Segment] -> Path
Path Bool
True [Segment
""]
    | Bool
otherwise = Bool -> [Segment] -> Path
Path Bool
True ([Segment] -> Path) -> [Segment] -> Path
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


-- | Use the default route if it's empty
findRoute :: (Route a) => [Text] -> 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 = Path -> Maybe a
forall a. Route a => Path -> Maybe a
matchRoute (Bool -> [Segment] -> Path
Path Bool
True [Segment]
ps)


pathUrl :: Path -> Url
pathUrl :: Path -> Url
pathUrl (Path Bool
True [Segment]
ss) = Segment -> Url
Url (Segment -> Url) -> Segment -> Url
forall a b. (a -> b) -> a -> b
$ Segment
"/" Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment -> [Segment] -> Segment
intercalate Segment
"/" [Segment]
ss
pathUrl (Path Bool
False [Segment]
ss) = Segment -> Url
Url (Segment -> Url) -> Segment -> Url
forall a b. (a -> b) -> a -> b
$ Segment -> [Segment] -> Segment
intercalate Segment
"/" [Segment]
ss


cleanSegment :: Segment -> Segment
cleanSegment :: Segment -> Segment
cleanSegment = (Char -> Bool) -> Segment -> Segment
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Segment -> Segment) -> (Segment -> Segment) -> Segment -> Segment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Segment -> Segment
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')


pathSegments :: Text -> [Segment]
pathSegments :: Segment -> [Segment]
pathSegments Segment
path = HasCallStack => Segment -> Segment -> [Segment]
Segment -> Segment -> [Segment]
splitOn Segment
"/" (Segment -> [Segment]) -> Segment -> [Segment]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Segment -> Segment
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Segment
path


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 :: String
name = M1 C c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
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 (String -> Segment
pack String
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 :: String
name = M1 C c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
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 (String -> Segment
pack String
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
<$> Path -> Maybe sub
forall a. Route a => Path -> Maybe a
matchRoute (Bool -> [Segment] -> Path
Path Bool
True [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 -> 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 [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
<$> String -> Maybe x
forall a. Read a => String -> Maybe a
readMaybe (Segment -> String
unpack Segment
t)
genRouteRead [Segment]
_ = Maybe (K1 R x a)
forall a. Maybe a
Nothing


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


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


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
  defRoute :: Integer
defRoute = Integer
0


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
  defRoute :: Int
defRoute = Int
0


instance (Route a) => Route (Maybe a) where
  matchRoute :: Path -> Maybe (Maybe a)
matchRoute (Path Bool
_ []) = 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 = Bool -> [Segment] -> Path
Path Bool
False []
  defRoute :: Maybe a
defRoute = Maybe a
forall a. Maybe a
Nothing


matchRouteRead :: (Read a) => Path -> Maybe a
matchRouteRead :: forall a. Read a => Path -> Maybe a
matchRouteRead (Path Bool
_ [Segment
t]) = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Segment -> String
unpack 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 = Bool -> [Segment] -> Path
Path Bool
False [String -> Segment
pack (a -> String
forall a. Show a => a -> String
show a
a)]