{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Rowdy.Yesod.Internal where
import Data.Char (toUpper)
import Data.Either (isLeft, lefts, rights)
import Data.Maybe (isJust)
import Data.String (IsString (..))
import Data.Typeable (Proxy (..), Typeable, eqT, typeRep)
import Yesod.Routes.TH.Types
import Rowdy
data Endpoint
= MkResource Verb String
| MkSubsite String String String
deriving (Endpoint -> Endpoint -> Bool
(Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool) -> Eq Endpoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Endpoint -> Endpoint -> Bool
$c/= :: Endpoint -> Endpoint -> Bool
== :: Endpoint -> Endpoint -> Bool
$c== :: Endpoint -> Endpoint -> Bool
Eq, Int -> Endpoint -> ShowS
[Endpoint] -> ShowS
Endpoint -> String
(Int -> Endpoint -> ShowS)
-> (Endpoint -> String) -> ([Endpoint] -> ShowS) -> Show Endpoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Endpoint] -> ShowS
$cshowList :: [Endpoint] -> ShowS
show :: Endpoint -> String
$cshow :: Endpoint -> String
showsPrec :: Int -> Endpoint -> ShowS
$cshowsPrec :: Int -> Endpoint -> ShowS
Show)
data PathPiece
= Literal String
| Capture Type
| Attr String
deriving (PathPiece -> PathPiece -> Bool
(PathPiece -> PathPiece -> Bool)
-> (PathPiece -> PathPiece -> Bool) -> Eq PathPiece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathPiece -> PathPiece -> Bool
$c/= :: PathPiece -> PathPiece -> Bool
== :: PathPiece -> PathPiece -> Bool
$c== :: PathPiece -> PathPiece -> Bool
Eq, Int -> PathPiece -> ShowS
[PathPiece] -> ShowS
PathPiece -> String
(Int -> PathPiece -> ShowS)
-> (PathPiece -> String)
-> ([PathPiece] -> ShowS)
-> Show PathPiece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathPiece] -> ShowS
$cshowList :: [PathPiece] -> ShowS
show :: PathPiece -> String
$cshow :: PathPiece -> String
showsPrec :: Int -> PathPiece -> ShowS
$cshowsPrec :: Int -> PathPiece -> ShowS
Show)
instance IsString PathPiece where
fromString :: String -> PathPiece
fromString = String -> PathPiece
Literal
data Type where
Type :: Typeable t => Proxy t -> Type
instance Show Type where
show :: Type -> String
show (Type Proxy t
prxy) = TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy t
prxy)
instance Eq Type where
Type (Proxy t
_ :: Proxy t0) == :: Type -> Type -> Bool
== Type (Proxy t
_ :: Proxy t1) =
Maybe (t :~: t) -> Bool
forall a. Maybe a -> Bool
isJust ((Typeable t, Typeable t) => Maybe (t :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t0 @t1)
data Verb = Get | Put | Post | Delete
deriving (Verb -> Verb -> Bool
(Verb -> Verb -> Bool) -> (Verb -> Verb -> Bool) -> Eq Verb
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verb -> Verb -> Bool
$c/= :: Verb -> Verb -> Bool
== :: Verb -> Verb -> Bool
$c== :: Verb -> Verb -> Bool
Eq, Int -> Verb -> ShowS
[Verb] -> ShowS
Verb -> String
(Int -> Verb -> ShowS)
-> (Verb -> String) -> ([Verb] -> ShowS) -> Show Verb
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verb] -> ShowS
$cshowList :: [Verb] -> ShowS
show :: Verb -> String
$cshow :: Verb -> String
showsPrec :: Int -> Verb -> ShowS
$cshowsPrec :: Int -> Verb -> ShowS
Show)
renderVerb :: Verb -> String
renderVerb :: Verb -> String
renderVerb = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> (Verb -> String) -> Verb -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verb -> String
forall a. Show a => a -> String
show
routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String]
routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String]
routeTreeToResourceTree =
(RouteTree String PathPiece Endpoint
-> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> [RouteTree String PathPiece Endpoint]
-> [ResourceTree String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go []) []
where
go
:: [Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go :: [Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go [Either String (Piece String)]
pcs (Nest String
str [RouteTree String PathPiece Endpoint]
xs) [ResourceTree String]
acc =
String
-> Bool
-> [Piece String]
-> [ResourceTree String]
-> ResourceTree String
forall typ.
String
-> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
ResourceParent String
str Bool
True [Piece String]
pieces ((RouteTree String PathPiece Endpoint
-> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> [RouteTree String PathPiece Endpoint]
-> [ResourceTree String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go [Either String (Piece String)]
attrs) [] [RouteTree String PathPiece Endpoint]
xs) ResourceTree String
-> [ResourceTree String] -> [ResourceTree String]
forall a. a -> [a] -> [a]
: [ResourceTree String]
acc
where
pieces :: [Piece String]
pieces = [Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)
attrs :: [Either String (Piece String)]
attrs = (Either String (Piece String) -> Bool)
-> [Either String (Piece String)] -> [Either String (Piece String)]
forall a. (a -> Bool) -> [a] -> [a]
filter Either String (Piece String) -> Bool
forall a b. Either a b -> Bool
isLeft [Either String (Piece String)]
pcs
go [Either String (Piece String)]
pcs (PathComponent PathPiece
pp RouteTree String PathPiece Endpoint
rest) [ResourceTree String]
acc =
[Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go (PathPiece -> Either String (Piece String)
convPiece PathPiece
pp Either String (Piece String)
-> [Either String (Piece String)] -> [Either String (Piece String)]
forall a. a -> [a] -> [a]
: [Either String (Piece String)]
pcs) RouteTree String PathPiece Endpoint
rest [ResourceTree String]
acc
go [Either String (Piece String)]
pcs (Leaf Endpoint
term) (ResourceLeaf Resource {Bool
String
[String]
[Piece String]
Dispatch String
resourceName :: forall typ. Resource typ -> String
resourcePieces :: forall typ. Resource typ -> [Piece typ]
resourceDispatch :: forall typ. Resource typ -> Dispatch typ
resourceAttrs :: forall typ. Resource typ -> [String]
resourceCheck :: forall typ. Resource typ -> Bool
resourceCheck :: Bool
resourceAttrs :: [String]
resourceDispatch :: Dispatch String
resourcePieces :: [Piece String]
resourceName :: String
..} : [ResourceTree String]
acc)
| (Piece String -> Piece String -> Bool)
-> [Piece String] -> [Piece String] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq Piece String -> Piece String -> Bool
eqPieceStr ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)) [Piece String]
resourcePieces
, Methods Maybe String
multi [String]
methods <- Dispatch String
resourceDispatch
, MkResource Verb
_ String
endpointName <- Endpoint
term
, String
resourceName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
endpointName
=
(ResourceTree String
-> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> ResourceTree String
-> [ResourceTree String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:) [ResourceTree String]
acc (ResourceTree String -> [ResourceTree String])
-> (Resource String -> ResourceTree String)
-> Resource String
-> [ResourceTree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource String -> ResourceTree String
forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (Resource String -> [ResourceTree String])
-> Resource String -> [ResourceTree String]
forall a b. (a -> b) -> a -> b
$
case Endpoint
term of
MkResource Verb
v String
str ->
Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
{ resourceName :: String
resourceName = String
str
, resourcePieces :: [Piece String]
resourcePieces = [Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)
, resourceDispatch :: Dispatch String
resourceDispatch =
Methods :: forall typ. Maybe typ -> [String] -> Dispatch typ
Methods
{ methodsMulti :: Maybe String
methodsMulti = Maybe String
multi
, methodsMethods :: [String]
methodsMethods = Verb -> String
renderVerb Verb
v String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
methods
}
, resourceAttrs :: [String]
resourceAttrs =
[Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
, resourceCheck :: Bool
resourceCheck =
Bool
True
}
MkSubsite String
str String
typ String
func ->
Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
{ resourceName :: String
resourceName = String
str
, resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
, resourceDispatch :: Dispatch String
resourceDispatch =
Subsite :: forall typ. typ -> String -> Dispatch typ
Subsite
{ subsiteType :: String
subsiteType = String
typ
, subsiteFunc :: String
subsiteFunc = String
func
}
, resourceAttrs :: [String]
resourceAttrs =
[Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
, resourceCheck :: Bool
resourceCheck =
Bool
True
}
go [Either String (Piece String)]
pcs (Leaf Endpoint
term) [ResourceTree String]
acc =
(ResourceTree String
-> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> ResourceTree String
-> [ResourceTree String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:) [ResourceTree String]
acc (ResourceTree String -> [ResourceTree String])
-> (Resource String -> ResourceTree String)
-> Resource String
-> [ResourceTree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource String -> ResourceTree String
forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (Resource String -> [ResourceTree String])
-> Resource String -> [ResourceTree String]
forall a b. (a -> b) -> a -> b
$
case Endpoint
term of
MkResource Verb
v String
str ->
Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
{ resourceName :: String
resourceName = String
str
, resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
, resourceDispatch :: Dispatch String
resourceDispatch =
Methods :: forall typ. Maybe typ -> [String] -> Dispatch typ
Methods
{ methodsMulti :: Maybe String
methodsMulti = Maybe String
forall a. Maybe a
Nothing
, methodsMethods :: [String]
methodsMethods = [Verb -> String
renderVerb Verb
v]
}
, resourceAttrs :: [String]
resourceAttrs =
[Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
, resourceCheck :: Bool
resourceCheck =
Bool
True
}
MkSubsite String
str String
typ String
func ->
Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
{ resourceName :: String
resourceName = String
str
, resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
, resourceDispatch :: Dispatch String
resourceDispatch =
Subsite :: forall typ. typ -> String -> Dispatch typ
Subsite
{ subsiteType :: String
subsiteType = String
typ
, subsiteFunc :: String
subsiteFunc = String
func
}
, resourceAttrs :: [String]
resourceAttrs =
[Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
, resourceCheck :: Bool
resourceCheck =
Bool
True
}
convPiece :: PathPiece -> Either String (Piece String)
convPiece :: PathPiece -> Either String (Piece String)
convPiece = \case
Literal String
str -> Piece String -> Either String (Piece String)
forall a b. b -> Either a b
Right (String -> Piece String
forall typ. String -> Piece typ
Static String
str)
Capture (Type Proxy t
prxy) -> Piece String -> Either String (Piece String)
forall a b. b -> Either a b
Right (String -> Piece String
forall typ. typ -> Piece typ
Dynamic (TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy t
prxy)))
Attr String
attr -> String -> Either String (Piece String)
forall a b. a -> Either a b
Left String
attr
listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq a -> a -> Bool
f (a
x:[a]
xs) (a
y:[a]
ys) = a -> a -> Bool
f a
x a
y Bool -> Bool -> Bool
&& (a -> a -> Bool) -> [a] -> [a] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq a -> a -> Bool
f [a]
xs [a]
ys
listEq a -> a -> Bool
_ [] [] = Bool
True
listEq a -> a -> Bool
_ [a]
_ [a]
_ = Bool
False
eqPieceStr :: Piece String -> Piece String -> Bool
eqPieceStr :: Piece String -> Piece String -> Bool
eqPieceStr (Static String
s2) (Static String
s1) = String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s2
eqPieceStr (Dynamic String
d0) (Dynamic String
d1) = String
d0 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d1
eqPieceStr Piece String
_ Piece String
_ = Bool
False