{-# LANGUAGE CPP #-}
module Freckle.App.Yesod.Routes
( mkRouteNameCaseExp
) where
import Freckle.App.Prelude
import qualified Language.Haskell.TH 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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) = 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 <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"a"
let
paramVars :: [Pat]
paramVars =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Pat
TH.WildP) (forall a. (a -> CheckOverlap) -> [a] -> [a]
filter forall a. Piece a -> CheckOverlap
isDynamic [Piece String]
params) forall a. Semigroup a => a -> a -> a
<> [Name -> Pat
TH.VarP Name
caseVar]
[Match]
matches <- forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ResourceTree String -> Q [Match]
mkMatches [ResourceTree String]
children
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Pat -> Body -> [Dec] -> Match
TH.Match
(Name -> [Pat] -> Pat
conP Name
constName [Pat]
paramVars)
(Exp -> Body
TH.NormalB 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
conP :: TH.Name -> [TH.Pat] -> TH.Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP :: Name -> [Pat] -> Pat
conP Name
x = Name -> [Type] -> [Pat] -> Pat
TH.ConP Name
x []
#else
conP = TH.ConP
#endif
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 forall a b. (a -> b) -> a -> b
$ Lit -> Exp
TH.LitE 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 = forall typ. Resource typ -> String
resourceName Resource String
resource