Routes.hs

{-# 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 tree = TH.LamCaseE . fold <$> traverse mkMatches tree

-- | Make match expressions for a big case over routes
--
-- > RoutePiece a -> case a of
-- >   ...
mkMatches :: ResourceTree String -> TH.Q [TH.Match]
mkMatches (ResourceLeaf resource) = pure [mkLeafMatch resource]
mkMatches (ResourceParent name _checkOverlap params children) = do
  caseVar <- TH.newName "a"
  let -- by convention the final param in a route is the next route constructor
      paramVars =
        fmap (const TH.WildP) (filter isDynamic params) <> [TH.VarP caseVar]
  matches <- fold <$> traverse mkMatches children
  pure
    [ TH.Match
        (conP constName paramVars)
        (TH.NormalB $ TH.CaseE (TH.VarE caseVar) matches)
        []
    ]
 where
  constName = TH.mkName name

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

isDynamic :: Piece a -> Bool
isDynamic = \case
  Static {} -> False
  Dynamic {} -> True

-- | Leaf match expressions for a resource
--
-- > Name{} -> "ResourceName"
mkLeafMatch :: Resource String -> TH.Match
mkLeafMatch resource =
  TH.Match
    (TH.RecP constName [])
    (TH.NormalB $ TH.LitE $ TH.StringL name)
    []
 where
  constName = TH.mkName name
  name = resourceName resource