    {-# LANGUAGE TemplateHaskell #-}

    module Yesod.Routes.TH.ParseRoute
        ( -- ** ParseRoute
          mkParseRouteInstance
        ) where

    import Yesod.Routes.TH.Types
    import Language.Haskell.TH.Syntax
    import Data.Text (Text)
    import Yesod.Routes.Class
    import Yesod.Routes.TH.Dispatch

    mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
    mkParseRouteInstance :: forall a. Cxt -> Type -> [ResourceTree a] -> Q Dec
    mkParseRouteInstance Cxt
    cxt Type
    typ [ResourceTree a]
    ress = do
        cls <- MkDispatchSettings (ZonkAny 2) (ZonkAny 1) (ZonkAny 0)
    -> [ResourceTree a] -> Q Clause
    forall b site c a.
    MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
    mkDispatchClause
            MkDispatchSettings
                { mdsRunHandler :: Q Exp
    mdsRunHandler = [|\_ _ x _ -> x|]
                , mds404 :: Q Exp
    mds404 = [|error "mds404"|]
                , mds405 :: Q Exp
    mds405 = [|error "mds405"|]
                , mdsGetPathInfo :: Q Exp
    mdsGetPathInfo = [|fst|]
                , mdsMethod :: Q Exp
    mdsMethod = [|error "mdsMethod"|]
                , mdsGetHandler :: Maybe String -> String -> Q Exp
    mdsGetHandler = \Maybe String
    _ String
    _ -> [|error "mdsGetHandler"|]
                , mdsSetPathInfo :: Q Exp
    mdsSetPathInfo = [|\p (_, q) -> (p, q)|]
                , mdsSubDispatcher :: Q Exp
    mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]
                , mdsUnwrapper :: Exp -> Q Exp
    mdsUnwrapper = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                }
            ((ResourceTree a -> ResourceTree a)
    -> [ResourceTree a] -> [ResourceTree a]
    forall a b. (a -> b) -> [a] -> [b]
    map ResourceTree a -> ResourceTree a
    forall {typ}. ResourceTree typ -> ResourceTree typ
    removeMethods [ResourceTree a]
    ress)
        helper <- newName "helper"
        fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
        return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
            [ FunD 'parseRoute $ return $ Clause
                []
                (NormalB $ fixer `AppE` VarE helper)
                [FunD helper [cls]]
            ]
      where
        -- We do this in order to ski the unnecessary method parsing
        removeMethods :: ResourceTree typ -> ResourceTree typ
    removeMethods (ResourceLeaf Resource typ
    res) = Resource typ -> ResourceTree typ
    forall typ. Resource typ -> ResourceTree typ
    ResourceLeaf (Resource typ -> ResourceTree typ)
    -> Resource typ -> ResourceTree typ
    forall a b. (a -> b) -> a -> b
    $ Resource typ -> Resource typ
    forall {typ}. Resource typ -> Resource typ
    removeMethodsLeaf Resource typ
    res
        removeMethods (ResourceParent String
    w CheckOverlap
    x [Piece typ]
    y [ResourceTree typ]
    z) = String
    -> CheckOverlap
    -> [Piece typ]
    -> [ResourceTree typ]
    -> ResourceTree typ
    forall typ.
    String
    -> CheckOverlap
    -> [Piece typ]
    -> [ResourceTree typ]
    -> ResourceTree typ
    ResourceParent String
    w CheckOverlap
    x [Piece typ]
    y ([ResourceTree typ] -> ResourceTree typ)
    -> [ResourceTree typ] -> ResourceTree typ
    forall a b. (a -> b) -> a -> b
    $ (ResourceTree typ -> ResourceTree typ)
    -> [ResourceTree typ] -> [ResourceTree typ]
    forall a b. (a -> b) -> [a] -> [b]
    map ResourceTree typ -> ResourceTree typ
    removeMethods [ResourceTree typ]
    z

        removeMethodsLeaf :: Resource typ -> Resource typ
    removeMethodsLeaf Resource typ
    res = Resource typ
    res { resourceDispatch = fixDispatch $ resourceDispatch res }

        fixDispatch :: Dispatch typ -> Dispatch typ
    fixDispatch (Methods Maybe typ
    x [String]
    _) = Maybe typ -> [String] -> Dispatch typ
    forall typ. Maybe typ -> [String] -> Dispatch typ
    Methods Maybe typ
    x []
        fixDispatch Dispatch typ
    x = Dispatch typ
    x

    instanceD :: Cxt -> Type -> [Dec] -> Dec
    instanceD :: Cxt -> Type -> [Dec] -> Dec
    instanceD = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing