57 lines
2.5 KiB
Haskell
57 lines
2.5 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Utils.Route where
|
|
|
|
import Control.Lens
|
|
import ClassyPrelude.Yesod hiding (Proxy)
|
|
import Data.Kind (Type)
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Proxy
|
|
|
|
|
|
class RedirectUrl site url => HasRoute site url where
|
|
type RouteWithParams site url :: Type
|
|
type RouteWithParams site url = (Route site, [(Text, Text)])
|
|
urlRoute :: url -> Route site
|
|
urlRouteParams :: forall p. p site -> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)]
|
|
default urlRouteParams :: forall p.
|
|
RouteWithParams site url ~ (Route site, [(Text, Text)])
|
|
=> p site
|
|
-> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)]
|
|
urlRouteParams _ = lens (const []) (\(urlRoute -> route') params -> (route', params))
|
|
|
|
instance HasRoute site (Route site) where
|
|
urlRoute = id
|
|
-- | for GET-Parameters
|
|
instance (key ~ Text) => HasRoute site (Route site, Map key Text) where
|
|
urlRoute = view _1
|
|
urlRouteParams _ = lens (views _2 Map.toList) (\(route, _) params -> (route, params))
|
|
-- | for GET-Parameters
|
|
instance (key ~ Text) => HasRoute site (Route site, [(key, Text)]) where
|
|
urlRoute = view _1
|
|
urlRouteParams _ = _2
|
|
-- | for PageAnchors, implemented through Fragments
|
|
instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
|
|
type RouteWithParams site (Fragment a b) = Fragment (RouteWithParams site a) b
|
|
urlRoute (a :#: _) = urlRoute a
|
|
urlRouteParams pSite = fragRoute . urlRouteParams pSite
|
|
where
|
|
fragRoute :: forall a1 a2 b'. Lens (Fragment a1 b') (Fragment a2 b') a1 a2
|
|
fragRoute = lens (\(a :#: _) -> a) (\(_ :#: f) a' -> a' :#: f)
|
|
|
|
data SomeRoute site = forall url. HasRoute site url => SomeRoute url
|
|
|
|
instance RedirectUrl site (SomeRoute site) where
|
|
toTextUrl (SomeRoute url) = toTextUrl url
|
|
instance HasRoute site (SomeRoute site) where
|
|
type RouteWithParams site (SomeRoute site) = SomeRoute site
|
|
urlRoute (SomeRoute url) = urlRoute url
|
|
urlRouteParams pSite = lens (\(SomeRoute url) -> withLens (urlRouteParams pSite) $ \g _ -> g url) (\(SomeRoute url) params -> SomeRoute (urlRoute url :: Route site, params))
|
|
instance Eq (Route site) => Eq (SomeRoute site) where
|
|
(==) = (==) `on` (\(SomeRoute r) -> withLens (urlRouteParams $ Proxy @site) $ \g _ -> (urlRoute r :: Route site, sort $ g r))
|