Route.hs

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

@
#EMBED Example/Docs/App.hs data AppRoute

#EMBED Example/Docs/App.hs instance Route
@

>>> 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 = 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 p =
    case (p, baseRoute) of
      ([], Just b) -> pure b
      (_, _) -> genMatchRoute p.segments


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


genMatchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a
genMatchRoute segs = to <$> genRoute segs


genRoutePath :: (Generic a, GenRoute (Rep a)) => a -> [Segment]
genRoutePath = genPaths . from


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

>>> routeUri (User 100)
/user/100
-}
routeUri :: (Route a) => a -> URI
routeUri = pathUri . 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 ps = M1 <$> genRoute ps
  genPaths (M1 x) = genPaths x


-- Constructor names / lines
instance (Constructor c, GenRoute f) => GenRoute (M1 C c f) where
  genRoute (n : ps) = do
    -- take the first path off the list
    -- check that it matches the constructor name
    -- check that the rest matches
    let name = conName (undefined :: M1 C c f x)
    guard (n == toLower (pack name))
    M1 <$> genRoute ps
  genRoute [] = Nothing


  genPaths (M1 x) =
    let name = conName (undefined :: M1 C c f x)
     in filter (not . T.null) $ toLower (pack name) : genPaths x


-- Unary constructors
instance GenRoute U1 where
  genRoute [] = pure U1
  genRoute _ = Nothing
  genPaths _ = []


-- Selectors
instance (GenRoute f) => GenRoute (M1 S c f) where
  genRoute ps =
    M1 <$> genRoute ps


  genPaths (M1 x) = genPaths x


-- Sum types
instance (GenRoute a, GenRoute b) => GenRoute (a :+: b) where
  genRoute ps = L1 <$> genRoute ps <|> R1 <$> genRoute ps


  genPaths (L1 a) = genPaths a
  genPaths (R1 a) = genPaths a


-- Product types
instance (GenRoute a, GenRoute b) => GenRoute (a :*: b) where
  genRoute (p : ps) = do
    ga <- genRoute [p]
    gr <- genRoute ps
    pure $ ga :*: gr
  genRoute _ = Nothing


  genPaths (a :*: b) = genPaths a <> genPaths b


instance (Route sub) => GenRoute (K1 R sub) where
  genRoute ts = K1 <$> matchRoute (Path ts)
  genPaths (K1 sub) = (routePath sub).segments


genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a)
genRouteRead [t] = do
  K1 <$> readMaybe (unpack t)
genRouteRead _ = Nothing


instance Route Text where
  matchRoute [t] = pure t
  matchRoute _ = Nothing
  routePath t = [t]
  baseRoute = Nothing


instance Route String where
  matchRoute [t] = pure (unpack t)
  matchRoute _ = Nothing
  routePath t = [pack t]
  baseRoute = Nothing


instance Route Integer where
  matchRoute = matchRouteRead
  routePath = routePathShow
  baseRoute = Nothing


instance Route Int where
  matchRoute = matchRouteRead
  routePath = routePathShow
  baseRoute = Nothing


instance (Route a) => Route (Maybe a) where
  matchRoute [] = pure Nothing
  matchRoute ps = Just <$> matchRoute ps
  routePath (Just a) = routePath a
  routePath Nothing = []
  baseRoute = Nothing


matchRouteRead :: (Read a) => Path -> Maybe a
matchRouteRead [t] = readMaybe (unpack t)
matchRouteRead _ = Nothing


routePathShow :: (Show a) => a -> Path
routePathShow a = [pack (show a)]