{-# 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 :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance Cxt
cxt Type
typ [ResourceTree a]
ress = do
    Clause
cls <- MkDispatchSettings Any Any Any -> [ResourceTree a] -> Q Clause
forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause
        MkDispatchSettings :: forall b site c.
Q Exp
-> Q Exp
-> Q Exp
-> Q Exp
-> Q Exp
-> Q Exp
-> Q Exp
-> (Maybe String -> String -> Q Exp)
-> (Exp -> Q Exp)
-> MkDispatchSettings b site c
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 (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)
    Name
helper <- String -> Q Name
newName String
"helper"
    Exp
fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
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 ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            []
            (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
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) = 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 :: Dispatch typ
resourceDispatch = Dispatch typ -> Dispatch typ
forall typ. Dispatch typ -> Dispatch typ
fixDispatch (Dispatch typ -> Dispatch typ) -> Dispatch typ -> Dispatch typ
forall a b. (a -> b) -> a -> b
$ Resource typ -> Dispatch typ
forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource typ
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