{-# 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

-- | Lambdacase expression to print route names
--
-- It has the following type:
--
-- > _ :: Route a -> String
--
-- It produces code like:
--
-- > \case
-- >   RoutePiece a -> case a of
-- >     RouteResource{} -> "ResourceName"
--
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

-- | Make match expressions for a big case over routes
--
-- > RoutePiece a -> case a of
-- >   ...
--
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
    -- by convention the final param in a route is the next route constructor
    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

-- | Leaf match expressions for a resource
--
-- > Name{} -> "ResourceName"
--
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