30 lines
1.1 KiB
Haskell
30 lines
1.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils.TH.Routes
|
|
( classifyHandler'
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
import Yesod.Routes.TH.Types (ResourceTree, FlatResource(..), Piece(..), Dispatch(..), flatten)
|
|
|
|
import Language.Haskell.TH
|
|
|
|
|
|
classifyHandler' :: [ResourceTree String] -> ExpQ
|
|
classifyHandler' = lamCaseE . map toMatch . flatten
|
|
where
|
|
toMatch FlatResource{..} = match (toPattern frDispatch $ frParentPieces ++ [(frName, frPieces)]) (normalB . litE $ stringL frName) []
|
|
toPattern _ [] = error "Empty hierarchy in toPattern"
|
|
toPattern dp [(mkName -> con, dynPieces -> pieces)] = conP con $ replicate pieces wildP ++ dispatchPattern dp
|
|
toPattern dp ( (mkName -> con, dynPieces -> pieces) : xs) = conP con $ replicate pieces wildP ++ [ toPattern dp xs ]
|
|
dispatchPattern (Methods Nothing _) = []
|
|
dispatchPattern (Methods (Just _) _) = [wildP]
|
|
dispatchPattern (Subsite _ _) = [wildP]
|
|
|
|
dynPieces = length . mapMaybe onlyDyn
|
|
where
|
|
onlyDyn (Static _) = Nothing
|
|
onlyDyn p@(Dynamic _) = Just p
|