{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveLift #-}
-- | Warning! This module is considered internal and may have breaking changes
module Yesod.Routes.TH.Types
    ( -- * Data types
      Resource (..)
    , ResourceTree (..)
    , Piece (..)
    , Dispatch (..)
    , CheckOverlap
    , FlatResource (..)
      -- ** Helper functions
    , resourceMulti
    , resourceTreePieces
    , resourceTreeName
    , flatten
    ) where

import Language.Haskell.TH.Syntax

data ResourceTree typ
    = ResourceLeaf (Resource typ)
    | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
    deriving (ResourceTree typ -> Q Exp
ResourceTree typ -> Q (TExp (ResourceTree typ))
(ResourceTree typ -> Q Exp)
-> (ResourceTree typ -> Q (TExp (ResourceTree typ)))
-> Lift (ResourceTree typ)
forall typ. Lift typ => ResourceTree typ -> Q Exp
forall typ.
Lift typ =>
ResourceTree typ -> Q (TExp (ResourceTree typ))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: ResourceTree typ -> Q (TExp (ResourceTree typ))
$cliftTyped :: forall typ.
Lift typ =>
ResourceTree typ -> Q (TExp (ResourceTree typ))
lift :: ResourceTree typ -> Q Exp
$clift :: forall typ. Lift typ => ResourceTree typ -> Q Exp
Lift, Int -> ResourceTree typ -> ShowS
[ResourceTree typ] -> ShowS
ResourceTree typ -> String
(Int -> ResourceTree typ -> ShowS)
-> (ResourceTree typ -> String)
-> ([ResourceTree typ] -> ShowS)
-> Show (ResourceTree typ)
forall typ. Show typ => Int -> ResourceTree typ -> ShowS
forall typ. Show typ => [ResourceTree typ] -> ShowS
forall typ. Show typ => ResourceTree typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceTree typ] -> ShowS
$cshowList :: forall typ. Show typ => [ResourceTree typ] -> ShowS
show :: ResourceTree typ -> String
$cshow :: forall typ. Show typ => ResourceTree typ -> String
showsPrec :: Int -> ResourceTree typ -> ShowS
$cshowsPrec :: forall typ. Show typ => Int -> ResourceTree typ -> ShowS
Show, a -> ResourceTree b -> ResourceTree a
(a -> b) -> ResourceTree a -> ResourceTree b
(forall a b. (a -> b) -> ResourceTree a -> ResourceTree b)
-> (forall a b. a -> ResourceTree b -> ResourceTree a)
-> Functor ResourceTree
forall a b. a -> ResourceTree b -> ResourceTree a
forall a b. (a -> b) -> ResourceTree a -> ResourceTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ResourceTree b -> ResourceTree a
$c<$ :: forall a b. a -> ResourceTree b -> ResourceTree a
fmap :: (a -> b) -> ResourceTree a -> ResourceTree b
$cfmap :: forall a b. (a -> b) -> ResourceTree a -> ResourceTree b
Functor)

resourceTreePieces :: ResourceTree typ -> [Piece typ]
resourceTreePieces :: ResourceTree typ -> [Piece typ]
resourceTreePieces (ResourceLeaf Resource typ
r) = Resource typ -> [Piece typ]
forall typ. Resource typ -> [Piece typ]
resourcePieces Resource typ
r
resourceTreePieces (ResourceParent String
_ CheckOverlap
_ [Piece typ]
x [ResourceTree typ]
_) = [Piece typ]
x

resourceTreeName :: ResourceTree typ -> String
resourceTreeName :: ResourceTree typ -> String
resourceTreeName (ResourceLeaf Resource typ
r) = Resource typ -> String
forall typ. Resource typ -> String
resourceName Resource typ
r
resourceTreeName (ResourceParent String
x CheckOverlap
_ [Piece typ]
_ [ResourceTree typ]
_) = String
x

data Resource typ = Resource
    { Resource typ -> String
resourceName :: String
    , Resource typ -> [Piece typ]
resourcePieces :: [Piece typ]
    , Resource typ -> Dispatch typ
resourceDispatch :: Dispatch typ
    , Resource typ -> [String]
resourceAttrs :: [String]
    , Resource typ -> CheckOverlap
resourceCheck :: CheckOverlap
    }
    deriving (Resource typ -> Q Exp
Resource typ -> Q (TExp (Resource typ))
(Resource typ -> Q Exp)
-> (Resource typ -> Q (TExp (Resource typ))) -> Lift (Resource typ)
forall typ. Lift typ => Resource typ -> Q Exp
forall typ. Lift typ => Resource typ -> Q (TExp (Resource typ))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Resource typ -> Q (TExp (Resource typ))
$cliftTyped :: forall typ. Lift typ => Resource typ -> Q (TExp (Resource typ))
lift :: Resource typ -> Q Exp
$clift :: forall typ. Lift typ => Resource typ -> Q Exp
Lift, Int -> Resource typ -> ShowS
[Resource typ] -> ShowS
Resource typ -> String
(Int -> Resource typ -> ShowS)
-> (Resource typ -> String)
-> ([Resource typ] -> ShowS)
-> Show (Resource typ)
forall typ. Show typ => Int -> Resource typ -> ShowS
forall typ. Show typ => [Resource typ] -> ShowS
forall typ. Show typ => Resource typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Resource typ] -> ShowS
$cshowList :: forall typ. Show typ => [Resource typ] -> ShowS
show :: Resource typ -> String
$cshow :: forall typ. Show typ => Resource typ -> String
showsPrec :: Int -> Resource typ -> ShowS
$cshowsPrec :: forall typ. Show typ => Int -> Resource typ -> ShowS
Show, a -> Resource b -> Resource a
(a -> b) -> Resource a -> Resource b
(forall a b. (a -> b) -> Resource a -> Resource b)
-> (forall a b. a -> Resource b -> Resource a) -> Functor Resource
forall a b. a -> Resource b -> Resource a
forall a b. (a -> b) -> Resource a -> Resource b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Resource b -> Resource a
$c<$ :: forall a b. a -> Resource b -> Resource a
fmap :: (a -> b) -> Resource a -> Resource b
$cfmap :: forall a b. (a -> b) -> Resource a -> Resource b
Functor)

type CheckOverlap = Bool

data Piece typ = Static String | Dynamic typ
    deriving (Piece typ -> Q Exp
Piece typ -> Q (TExp (Piece typ))
(Piece typ -> Q Exp)
-> (Piece typ -> Q (TExp (Piece typ))) -> Lift (Piece typ)
forall typ. Lift typ => Piece typ -> Q Exp
forall typ. Lift typ => Piece typ -> Q (TExp (Piece typ))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Piece typ -> Q (TExp (Piece typ))
$cliftTyped :: forall typ. Lift typ => Piece typ -> Q (TExp (Piece typ))
lift :: Piece typ -> Q Exp
$clift :: forall typ. Lift typ => Piece typ -> Q Exp
Lift, Int -> Piece typ -> ShowS
[Piece typ] -> ShowS
Piece typ -> String
(Int -> Piece typ -> ShowS)
-> (Piece typ -> String)
-> ([Piece typ] -> ShowS)
-> Show (Piece typ)
forall typ. Show typ => Int -> Piece typ -> ShowS
forall typ. Show typ => [Piece typ] -> ShowS
forall typ. Show typ => Piece typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Piece typ] -> ShowS
$cshowList :: forall typ. Show typ => [Piece typ] -> ShowS
show :: Piece typ -> String
$cshow :: forall typ. Show typ => Piece typ -> String
showsPrec :: Int -> Piece typ -> ShowS
$cshowsPrec :: forall typ. Show typ => Int -> Piece typ -> ShowS
Show)

instance Functor Piece where
    fmap :: (a -> b) -> Piece a -> Piece b
fmap a -> b
_ (Static String
s)  = String -> Piece b
forall typ. String -> Piece typ
Static String
s
    fmap a -> b
f (Dynamic a
t) = b -> Piece b
forall typ. typ -> Piece typ
Dynamic (a -> b
f a
t)

data Dispatch typ =
    Methods
        { Dispatch typ -> Maybe typ
methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
        , Dispatch typ -> [String]
methodsMethods :: [String] -- ^ supported request methods
        }
    | Subsite
        { Dispatch typ -> typ
subsiteType :: typ
        , Dispatch typ -> String
subsiteFunc :: String
        }
    deriving (Dispatch typ -> Q Exp
Dispatch typ -> Q (TExp (Dispatch typ))
(Dispatch typ -> Q Exp)
-> (Dispatch typ -> Q (TExp (Dispatch typ))) -> Lift (Dispatch typ)
forall typ. Lift typ => Dispatch typ -> Q Exp
forall typ. Lift typ => Dispatch typ -> Q (TExp (Dispatch typ))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Dispatch typ -> Q (TExp (Dispatch typ))
$cliftTyped :: forall typ. Lift typ => Dispatch typ -> Q (TExp (Dispatch typ))
lift :: Dispatch typ -> Q Exp
$clift :: forall typ. Lift typ => Dispatch typ -> Q Exp
Lift, Int -> Dispatch typ -> ShowS
[Dispatch typ] -> ShowS
Dispatch typ -> String
(Int -> Dispatch typ -> ShowS)
-> (Dispatch typ -> String)
-> ([Dispatch typ] -> ShowS)
-> Show (Dispatch typ)
forall typ. Show typ => Int -> Dispatch typ -> ShowS
forall typ. Show typ => [Dispatch typ] -> ShowS
forall typ. Show typ => Dispatch typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dispatch typ] -> ShowS
$cshowList :: forall typ. Show typ => [Dispatch typ] -> ShowS
show :: Dispatch typ -> String
$cshow :: forall typ. Show typ => Dispatch typ -> String
showsPrec :: Int -> Dispatch typ -> ShowS
$cshowsPrec :: forall typ. Show typ => Int -> Dispatch typ -> ShowS
Show)

instance Functor Dispatch where
    fmap :: (a -> b) -> Dispatch a -> Dispatch b
fmap a -> b
f (Methods Maybe a
a [String]
b) = Maybe b -> [String] -> Dispatch b
forall typ. Maybe typ -> [String] -> Dispatch typ
Methods ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
a) [String]
b
    fmap a -> b
f (Subsite a
a String
b) = b -> String -> Dispatch b
forall typ. typ -> String -> Dispatch typ
Subsite (a -> b
f a
a) String
b

resourceMulti :: Resource typ -> Maybe typ
resourceMulti :: Resource typ -> Maybe typ
resourceMulti Resource { resourceDispatch :: forall typ. Resource typ -> Dispatch typ
resourceDispatch = Methods (Just typ
t) [String]
_ } = typ -> Maybe typ
forall a. a -> Maybe a
Just typ
t
resourceMulti Resource typ
_ = Maybe typ
forall a. Maybe a
Nothing

data FlatResource a = FlatResource
    { FlatResource a -> [(String, [Piece a])]
frParentPieces :: [(String, [Piece a])]
    , FlatResource a -> String
frName :: String
    , FlatResource a -> [Piece a]
frPieces :: [Piece a]
    , FlatResource a -> Dispatch a
frDispatch :: Dispatch a
    , FlatResource a -> CheckOverlap
frCheck :: Bool
    } deriving (Int -> FlatResource a -> ShowS
[FlatResource a] -> ShowS
FlatResource a -> String
(Int -> FlatResource a -> ShowS)
-> (FlatResource a -> String)
-> ([FlatResource a] -> ShowS)
-> Show (FlatResource a)
forall a. Show a => Int -> FlatResource a -> ShowS
forall a. Show a => [FlatResource a] -> ShowS
forall a. Show a => FlatResource a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlatResource a] -> ShowS
$cshowList :: forall a. Show a => [FlatResource a] -> ShowS
show :: FlatResource a -> String
$cshow :: forall a. Show a => FlatResource a -> String
showsPrec :: Int -> FlatResource a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FlatResource a -> ShowS
Show)

flatten :: [ResourceTree a] -> [FlatResource a]
flatten :: [ResourceTree a] -> [FlatResource a]
flatten =
    (ResourceTree a -> [FlatResource a])
-> [ResourceTree a] -> [FlatResource a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([(String, [Piece a])] -> [(String, [Piece a])])
-> CheckOverlap -> ResourceTree a -> [FlatResource a]
forall a.
([(String, [Piece a])] -> [(String, [Piece a])])
-> CheckOverlap -> ResourceTree a -> [FlatResource a]
go [(String, [Piece a])] -> [(String, [Piece a])]
forall a. a -> a
id CheckOverlap
True)
  where
    go :: ([(String, [Piece a])] -> [(String, [Piece a])])
-> CheckOverlap -> ResourceTree a -> [FlatResource a]
go [(String, [Piece a])] -> [(String, [Piece a])]
front CheckOverlap
check' (ResourceLeaf (Resource String
a [Piece a]
b Dispatch a
c [String]
_ CheckOverlap
check)) = [[(String, [Piece a])]
-> String
-> [Piece a]
-> Dispatch a
-> CheckOverlap
-> FlatResource a
forall a.
[(String, [Piece a])]
-> String
-> [Piece a]
-> Dispatch a
-> CheckOverlap
-> FlatResource a
FlatResource ([(String, [Piece a])] -> [(String, [Piece a])]
front []) String
a [Piece a]
b Dispatch a
c (CheckOverlap
check' CheckOverlap -> CheckOverlap -> CheckOverlap
&& CheckOverlap
check)]
    go [(String, [Piece a])] -> [(String, [Piece a])]
front CheckOverlap
check' (ResourceParent String
name CheckOverlap
check [Piece a]
pieces [ResourceTree a]
children) =
        (ResourceTree a -> [FlatResource a])
-> [ResourceTree a] -> [FlatResource a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([(String, [Piece a])] -> [(String, [Piece a])])
-> CheckOverlap -> ResourceTree a -> [FlatResource a]
go ([(String, [Piece a])] -> [(String, [Piece a])]
front ([(String, [Piece a])] -> [(String, [Piece a])])
-> ([(String, [Piece a])] -> [(String, [Piece a])])
-> [(String, [Piece a])]
-> [(String, [Piece a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
name, [Piece a]
pieces)(String, [Piece a])
-> [(String, [Piece a])] -> [(String, [Piece a])]
forall a. a -> [a] -> [a]
:)) (CheckOverlap
check CheckOverlap -> CheckOverlap -> CheckOverlap
&& CheckOverlap
check')) [ResourceTree a]
children