{-# 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
    Clause
cls <- 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 = forall (m :: * -> *) a. Monad m => a -> m a
return
            }
        (forall a b. (a -> b) -> [a] -> [b]
map forall {typ}. ResourceTree typ -> ResourceTree typ
removeMethods [ResourceTree a]
ress)
    Name
helper <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"helper"
    Exp
fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
cxt (Name -> Type
ConT ''ParseRoute Type -> Type -> Type
`AppT` Type
typ)
        [ Name -> [Clause] -> Dec
FunD 'parseRoute forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            []
            (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
fixer Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
helper)
            [Name -> [Clause] -> Dec
FunD Name
helper [Clause
cls]]
        ]
  where
    -- We do this in order to ski the unnecessary method parsing
    removeMethods :: ResourceTree typ -> ResourceTree typ
removeMethods (ResourceLeaf Resource typ
res) = forall typ. Resource typ -> ResourceTree typ
ResourceLeaf forall a b. (a -> b) -> a -> b
$ forall {typ}. Resource typ -> Resource typ
removeMethodsLeaf Resource typ
res
    removeMethods (ResourceParent String
w CheckOverlap
x [Piece typ]
y [ResourceTree typ]
z) = forall typ.
String
-> CheckOverlap
-> [Piece typ]
-> [ResourceTree typ]
-> ResourceTree typ
ResourceParent String
w CheckOverlap
x [Piece typ]
y forall a b. (a -> b) -> a -> b
$ 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 :: Dispatch typ
resourceDispatch = forall {typ}. Dispatch typ -> Dispatch typ
fixDispatch forall a b. (a -> b) -> a -> b
$ forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource typ
res }

    fixDispatch :: Dispatch typ -> Dispatch typ
fixDispatch (Methods Maybe typ
x [String]
_) = 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 forall a. Maybe a
Nothing