{-# 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 ([Match] -> Exp) -> ([[Match]] -> [Match]) -> [[Match]] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Match]] -> [Match]
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)
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) = [Match] -> Q [Match]
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
TH.newName String
"a"
  let
    -- by convention the final param in a route is the next route constructor
    paramVars :: [Pat]
paramVars =
      (Piece String -> Pat) -> [Piece String] -> [Pat]
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 (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)
traverse ResourceTree String -> Q [Match]
mkMatches [ResourceTree String]
children
  [Match] -> Q [Match]
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 (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

conP :: TH.Name -> [TH.Pat] -> TH.Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP x = TH.ConP x []
#else
conP :: Name -> [Pat] -> Pat
conP = Name -> [Pat] -> Pat
TH.ConP
#endif

isDynamic :: Piece a -> Bool
isDynamic :: 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 (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