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