{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Yesod.Routes.TH.RenderRoute
(
mkRenderRouteInstance
, mkRenderRouteInstanceOpts
, mkRouteCons
, mkRouteConsOpts
, mkRenderRouteClauses
, RouteOpts
, defaultOpts
, setEqDerived
, setShowDerived
, setReadDerived
) 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
data RouteOpts = MkRouteOpts
{ RouteOpts -> Bool
roDerivedEq :: Bool
, RouteOpts -> Bool
roDerivedShow :: Bool
, RouteOpts -> Bool
roDerivedRead :: Bool
}
defaultOpts :: RouteOpts
defaultOpts :: RouteOpts
defaultOpts = Bool -> Bool -> Bool -> RouteOpts
MkRouteOpts Bool
True Bool
True Bool
True
setEqDerived :: Bool -> RouteOpts -> RouteOpts
setEqDerived :: Bool -> RouteOpts -> RouteOpts
setEqDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedEq :: Bool
roDerivedEq = Bool
b }
setShowDerived :: Bool -> RouteOpts -> RouteOpts
setShowDerived :: Bool -> RouteOpts -> RouteOpts
setShowDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedShow :: Bool
roDerivedShow = Bool
b }
setReadDerived :: Bool -> RouteOpts -> RouteOpts
setReadDerived :: Bool -> RouteOpts -> RouteOpts
setReadDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedRead :: Bool
roDerivedRead = Bool
b }
instanceNamesFromOpts :: RouteOpts -> [Name]
instanceNamesFromOpts :: RouteOpts -> [Name]
instanceNamesFromOpts (MkRouteOpts Bool
eq Bool
shw Bool
rd) = forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
eq ''Eq forall a b. (a -> b) -> a -> b
$ forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
shw ''Show forall a b. (a -> b) -> a -> b
$ forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
rd ''Read []
where prependIf :: Bool -> a -> [a] -> [a]
prependIf Bool
b = if Bool
b then (:) else forall a b. a -> b -> a
const forall a. a -> a
id
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteCons = RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteConsOpts RouteOpts
defaultOpts
mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteConsOpts RouteOpts
opts [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 (Bang
notStrict,)
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 Bool
_check [Piece Type]
pieces [ResourceTree Type]
children) = do
([Con]
cons, [Dec]
decs) <- RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteConsOpts RouteOpts
opts [ResourceTree Type]
children
let conts :: Q [Type]
conts = 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 forall a b. (a -> b) -> a -> b
$ RouteOpts -> [Name]
instanceNamesFromOpts RouteOpts
opts
#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) Q [Type]
conts
#else
dec <- DataD [] (mkName name) [] Nothing cons <$> conts
#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 (Bang
notStrict,)
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]
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 -> Bool
isDynamic Dynamic{} = Bool
True
isDynamic Piece typ
_ = Bool
False
go :: ResourceTree Type -> Q Clause
go (ResourceParent String
name Bool
_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 -> Bool) -> [a] -> [a]
filter forall {typ}. Piece typ -> Bool
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 -> Bool) -> [a] -> [a]
filter forall {typ}. Piece typ -> Bool
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"
mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance :: [Type] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance = RouteOpts -> [Type] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts RouteOpts
defaultOpts
mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts :: RouteOpts -> [Type] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts RouteOpts
opts [Type]
cxt Type
typ [ResourceTree Type]
ress = do
[Clause]
cls <- [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses [ResourceTree Type]
ress
([Con]
cons, [Dec]
decs) <- RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
mkRouteConsOpts RouteOpts
opts [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 (Bool -> [Name]
clazzes Bool
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)) (Bool -> [Name]
clazzes Bool
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 :: Bool -> [Name]
clazzes Bool
standalone = if Bool
standalone forall a. Bits a => a -> a -> a
`xor` forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
cxt then
[Name]
clazzes'
else
[]
clazzes' :: [Name]
clazzes' = RouteOpts -> [Name]
instanceNamesFromOpts RouteOpts
opts
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