{-# LANGUAGE TemplateHaskell, CPP #-}
module Yesod.Routes.TH.RenderRoute
    ( -- ** RenderRoute
      mkRenderRouteInstance
    , mkRouteCons
    , mkRenderRouteClauses
    ) where

import Yesod.Routes.TH.Types
import Language.Haskell.TH (conT)
import Language.Haskell.TH.Syntax
import Data.Bits (xor)
import Data.Maybe (maybeToList)
import Control.Monad (replicateM)
import Data.Text (pack)
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class

-- | Generate the constructors of a route data type.
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons [ResourceTree Type]
rttypes =
    forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ResourceTree Type -> Q ([Con], [Dec])
mkRouteCon [ResourceTree Type]
rttypes
  where
    mkRouteCon :: ResourceTree Type -> Q ([Con], [Dec])
mkRouteCon (ResourceLeaf Resource Type
res) =
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Con
con], [])
      where
        con :: Con
con = Name -> [BangType] -> Con
NormalC (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> String
resourceName Resource Type
res)
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Type
x -> (Bang
notStrict, Type
x))
            forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]
singles, [Type]
multi, [Type]
sub]
        singles :: [Type]
singles = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Piece a -> [a]
toSingle forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res
        toSingle :: Piece a -> [a]
toSingle Static{} = []
        toSingle (Dynamic a
typ) = [a
typ]

        multi :: [Type]
multi = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res

        sub :: [Type]
sub =
            case forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource Type
res of
                Subsite { subsiteType :: forall typ. Dispatch typ -> typ
subsiteType = Type
typ } -> [Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Type
typ]
                Dispatch Type
_ -> []

    mkRouteCon (ResourceParent String
name CheckOverlap
_check [Piece Type]
pieces [ResourceTree Type]
children) = do
        ([Con]
cons, [Dec]
decs) <- [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons [ResourceTree Type]
children
#if MIN_VERSION_template_haskell(2,12,0)
        Dec
dec <- [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] (String -> Name
mkName String
name) [] forall a. Maybe a
Nothing [Con]
cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). Quote m => Name -> m Type
conT [''Show, ''Read, ''Eq])
#else
        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
#endif
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Con
con], Dec
dec forall a. a -> [a] -> [a]
: [Dec]
decs)
      where
        con :: Con
con = Name -> [BangType] -> Con
NormalC (String -> Name
mkName String
name)
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Type
x -> (Bang
notStrict, Type
x))
            forall a b. (a -> b) -> a -> b
$ [Type]
singles forall a. [a] -> [a] -> [a]
++ [Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
name]

        singles :: [Type]
singles = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Piece a -> [a]
toSingle [Piece Type]
pieces
        toSingle :: Piece a -> [a]
toSingle Static{} = []
        toSingle (Dynamic a
typ) = [a
typ]

-- | Clauses for the 'renderRoute' method.
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ResourceTree Type -> Q Clause
go
  where
    isDynamic :: Piece typ -> CheckOverlap
isDynamic Dynamic{} = CheckOverlap
True
    isDynamic Piece typ
_ = CheckOverlap
False

    go :: ResourceTree Type -> Q Clause
go (ResourceParent String
name CheckOverlap
_check [Piece Type]
pieces [ResourceTree Type]
children) = do
        let cnt :: Int
cnt = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> CheckOverlap) -> [a] -> [a]
filter forall {typ}. Piece typ -> CheckOverlap
isDynamic [Piece Type]
pieces
        [Name]
dyns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
cnt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
        Name
child <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"child"
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName String
name) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ [Name]
dyns forall a. [a] -> [a] -> [a]
++ [Name
child]

        Exp
pack' <- [|pack|]
        Exp
tsp <- [|toPathPiece|]
        let piecesSingle :: [Exp]
piecesSingle = forall {typ}.
(String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces (Exp -> Exp -> Exp
AppE Exp
pack' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL) Exp
tsp [Piece Type]
pieces [Name]
dyns

        Name
childRender <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"childRender"
        let rr :: Exp
rr = Name -> Exp
VarE Name
childRender
        [Clause]
childClauses <- [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses [ResourceTree Type]
children

        Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
        Name
b <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"

        Exp
colon <- [|(:)|]
        let cons :: Exp -> Exp -> Exp
cons Exp
y Exp
ys = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
y) Exp
colon (forall a. a -> Maybe a
Just Exp
ys)
        let pieces' :: Exp
pieces' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
cons (Name -> Exp
VarE Name
a) [Exp]
piecesSingle

        let body :: Exp
body = [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Name -> Pat
VarP Name
a, Name -> Pat
VarP Name
b]] ([Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                                                  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
                                                  [Exp
pieces', Name -> Exp
VarE Name
b]
                                                ) Exp -> Exp -> Exp
`AppE` (Exp
rr Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
child)

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) [Name -> [Clause] -> Dec
FunD Name
childRender [Clause]
childClauses]

    go (ResourceLeaf Resource Type
res) = do
        let cnt :: Int
cnt = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> CheckOverlap) -> [a] -> [a]
filter forall {typ}. Piece typ -> CheckOverlap
isDynamic forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res) forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a b. a -> b -> a
const Int
1) (forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res)
        [Name]
dyns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
cnt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
        [Name]
sub <-
            case forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource Type
res of
                Subsite{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"sub"
                Dispatch Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> String
resourceName Resource Type
res) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ [Name]
dyns forall a. [a] -> [a] -> [a]
++ [Name]
sub

        Exp
pack' <- [|pack|]
        Exp
tsp <- [|toPathPiece|]
        let piecesSingle :: [Exp]
piecesSingle = forall {typ}.
(String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces (Exp -> Exp -> Exp
AppE Exp
pack' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL) Exp
tsp (forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res) [Name]
dyns

        Exp
piecesMulti <-
            case forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res of
                Maybe Type
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE []
                Just{} -> do
                    Exp
tmp <- [|toPathMultiPiece|]
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
tmp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE (forall a. [a] -> a
last [Name]
dyns)

        Exp
body <-
            case [Name]
sub of
                [Name
x] -> do
                    Exp
rr <- [|renderRoute|]
                    Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                    Name
b <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"

                    Exp
colon <- [|(:)|]
                    let cons :: Exp -> Exp -> Exp
cons Exp
y Exp
ys = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
y) Exp
colon (forall a. a -> Maybe a
Just Exp
ys)
                    let pieces :: Exp
pieces = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
cons (Name -> Exp
VarE Name
a) [Exp]
piecesSingle

                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Name -> Pat
VarP Name
a, Name -> Pat
VarP Name
b]] ([Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                                                            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
                                                            [Exp
pieces, Name -> Exp
VarE Name
b]
                                                          ) Exp -> Exp -> Exp
`AppE` (Exp
rr Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)
                [Name]
_ -> do
                    Exp
colon <- [|(:)|]
                    let cons :: Exp -> Exp -> Exp
cons Exp
a Exp
b = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
a) Exp
colon (forall a. a -> Maybe a
Just Exp
b)
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
                      [forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
cons Exp
piecesMulti [Exp]
piecesSingle, [Exp] -> Exp
ListE []]

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []

    mkPieces :: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
_ Exp
_ [] [Name]
_ = []
    mkPieces String -> Exp
toText Exp
tsp (Static String
s:[Piece typ]
ps) [Name]
dyns = String -> Exp
toText String
s forall a. a -> [a] -> [a]
: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
toText Exp
tsp [Piece typ]
ps [Name]
dyns
    mkPieces String -> Exp
toText Exp
tsp (Dynamic{}:[Piece typ]
ps) (Name
d:[Name]
dyns) = Exp
tsp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
d forall a. a -> [a] -> [a]
: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
toText Exp
tsp [Piece typ]
ps [Name]
dyns
    mkPieces String -> Exp
_ Exp
_ (Dynamic typ
_ : [Piece typ]
_) [] = forall a. HasCallStack => String -> a
error String
"mkPieces 120"

-- | Generate the 'RenderRoute' instance.
--
-- This includes both the 'Route' associated type and the
-- 'renderRoute' method.  This function uses both 'mkRouteCons' and
-- 'mkRenderRouteClasses'.
mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance :: [Type] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance [Type]
cxt Type
typ [ResourceTree Type]
ress = do
    [Clause]
cls <- [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses [ResourceTree Type]
ress
    ([Con]
cons, [Dec]
decs) <- [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons [ResourceTree Type]
ress
#if MIN_VERSION_template_haskell(2,15,0)
    Dec
did <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT ''Route) Type
typ) forall a. Maybe a
Nothing [Con]
cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). Quote m => Name -> m Type
conT (CheckOverlap -> [Name]
clazzes CheckOverlap
False))
    let sds :: [Dec]
sds = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
t -> Maybe DerivStrategy -> [Type] -> Type -> Dec
StandaloneDerivD forall a. Maybe a
Nothing [Type]
cxt forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
t Type -> Type -> Type
`AppT` ( Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Type
typ)) (CheckOverlap -> [Name]
clazzes CheckOverlap
True)
#elif MIN_VERSION_template_haskell(2,12,0)
    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
    let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
#else
    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
#endif
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt (Name -> Type
ConT ''RenderRoute Type -> Type -> Type
`AppT` Type
typ)
        [ Dec
did
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"renderRoute") [Clause]
cls
        ]
        forall a. a -> [a] -> [a]
: [Dec]
sds forall a. [a] -> [a] -> [a]
++ [Dec]
decs
  where
    clazzes :: CheckOverlap -> [Name]
clazzes CheckOverlap
standalone = if CheckOverlap
standalone forall a. Bits a => a -> a -> a
`xor` forall (t :: * -> *) a. Foldable t => t a -> CheckOverlap
null [Type]
cxt then
          [Name]
clazzes'
        else
          []
    clazzes' :: [Name]
clazzes' = [''Show, ''Eq, ''Read]

notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: [Type] -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing

conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
                         []
#endif
                         [Pat]
pats