module Freckle.App.Yesod.Routes
( mkRouteNameCaseExp
) where
import Freckle.App.Prelude
import Language.Haskell.TH qualified as TH
import Yesod.Routes.TH.Types
mkRouteNameCaseExp :: [ResourceTree String] -> TH.Q TH.Exp
mkRouteNameCaseExp :: [ResourceTree String] -> Q Exp
mkRouteNameCaseExp [ResourceTree String]
tree = [Match] -> Exp
TH.LamCaseE ([Match] -> Exp) -> ([[Match]] -> [Match]) -> [[Match]] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Match]] -> [Match]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[Match]] -> Exp) -> Q [[Match]] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResourceTree String -> Q [Match])
-> [ResourceTree String] -> Q [[Match]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ResourceTree String -> Q [Match]
mkMatches [ResourceTree String]
tree
mkMatches :: ResourceTree String -> TH.Q [TH.Match]
mkMatches :: ResourceTree String -> Q [Match]
mkMatches (ResourceLeaf Resource String
resource) = [Match] -> Q [Match]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Resource String -> Match
mkLeafMatch Resource String
resource]
mkMatches (ResourceParent String
name CheckOverlap
_checkOverlap [Piece String]
params [ResourceTree String]
children) = do
Name
caseVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"a"
let
paramVars :: [Pat]
paramVars =
(Piece String -> Pat) -> [Piece String] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> Piece String -> Pat
forall a b. a -> b -> a
const Pat
TH.WildP) ((Piece String -> CheckOverlap) -> [Piece String] -> [Piece String]
forall a. (a -> CheckOverlap) -> [a] -> [a]
filter Piece String -> CheckOverlap
forall a. Piece a -> CheckOverlap
isDynamic [Piece String]
params) [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<> [Name -> Pat
TH.VarP Name
caseVar]
[Match]
matches <- [[Match]] -> [Match]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[Match]] -> [Match]) -> Q [[Match]] -> Q [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResourceTree String -> Q [Match])
-> [ResourceTree String] -> Q [[Match]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ResourceTree String -> Q [Match]
mkMatches [ResourceTree String]
children
[Match] -> Q [Match]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Pat -> Body -> [Dec] -> Match
TH.Match
(Name -> [Type] -> [Pat] -> Pat
TH.ConP Name
constName [] [Pat]
paramVars)
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
TH.CaseE (Name -> Exp
TH.VarE Name
caseVar) [Match]
matches)
[]
]
where
constName :: Name
constName = String -> Name
TH.mkName String
name
isDynamic :: Piece a -> Bool
isDynamic :: forall a. Piece a -> CheckOverlap
isDynamic = \case
Static {} -> CheckOverlap
False
Dynamic {} -> CheckOverlap
True
mkLeafMatch :: Resource String -> TH.Match
mkLeafMatch :: Resource String -> Match
mkLeafMatch Resource String
resource =
Pat -> Body -> [Dec] -> Match
TH.Match
(Name -> [FieldPat] -> Pat
TH.RecP Name
constName [])
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
TH.LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
TH.StringL String
name)
[]
where
constName :: Name
constName = String -> Name
TH.mkName String
name
name :: String
name = Resource String -> String
forall typ. Resource typ -> String
resourceName Resource String
resource