    {-# LANGUAGE TemplateHaskell #-}
    module Yesod.Routes.TH.Dispatch
        ( -- ** Dispatch
          mkDispatchClause
        , MkDispatchSettings (..)
        , defaultGetHandler
        ) where

    import Prelude hiding (exp)
    import Yesod.Routes.TH.Types
    import Language.Haskell.TH.Syntax
    import Data.Maybe (catMaybes)
    import Control.Monad (forM, replicateM)
    import Data.Text (pack)
    import qualified Yesod.Routes.Dispatch as D
    import qualified Data.Map as Map
    import Data.Char (toLower)
    import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
    import Control.Applicative ((<$>))
    import Data.List (foldl')
    import Data.Text.Encoding (encodeUtf8)

    data MkDispatchSettings = MkDispatchSettings
        { mdsRunHandler :: Q Exp
        , mdsSubDispatcher :: Q Exp
        , mdsGetPathInfo :: Q Exp
        , mdsSetPathInfo :: Q Exp
        , mdsMethod :: Q Exp
        , mds404 :: Q Exp
        , mds405 :: Q Exp
        , mdsGetHandler :: Maybe String -> String -> Q Exp
        }

    defaultGetHandler :: Maybe String -> String -> Q Exp
    defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
    defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s

    -- |
    --
    -- This function will generate a single clause that will address all
    -- your routing needs. It takes four arguments. The fourth (a list of
    -- 'Resource's) is self-explanatory. We\'ll discuss the first
    -- three. But first, let\'s cover the terminology.
    --
    -- Dispatching involves a master type and a sub type. When you dispatch to the
    -- top level type, master and sub are the same. Each time to dispatch to
    -- another subsite, the sub changes. This requires two changes:
    --
    -- * Getting the new sub value. This is handled via 'subsiteFunc'.
    --
    -- * Figure out a way to convert sub routes to the original master route. To
    -- address this, we keep a toMaster function, and each time we dispatch to a
    -- new subsite, we compose it with the constructor for that subsite.
    --
    -- Dispatching acts on two different components: the request method and a list
    -- of path pieces. If we cannot match the path pieces, we need to return a 404
    -- response. If the path pieces match, but the method is not supported, we need
    -- to return a 405 response.
    --
    -- The final result of dispatch is going to be an application type. A simple
    -- example would be the WAI Application type. However, our handler functions
    -- will need more input: the master/subsite, the toMaster function, and the
    -- type-safe route. Therefore, we need to have another type, the handler type,
    -- and a function that turns a handler into an application, i.e.
    --
    -- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app
    --
    -- This is the first argument to our function. Note that this will almost
    -- certainly need to be a method of a typeclass, since it will want to behave
    -- differently based on the subsite.
    --
    -- Note that the 404 response passed in is an application, while the 405
    -- response is a handler, since the former can\'t be passed the type-safe
    -- route.
    --
    -- In the case of a subsite, we don\'t directly deal with a handler function.
    -- Instead, we redispatch to the subsite, passing on the updated sub value and
    -- toMaster function, as well as any remaining, unparsed path pieces. This
    -- function looks like:
    --
    -- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app
    --
    -- Where the parameters mean master, sub, toMaster, 404 response, 405 response,
    -- request method and path pieces. This is the second argument of our function.
    --
    -- Finally, we need a way to decide which of the possible formats
    -- should the handler send the data out. Think of each URL holding an
    -- abstract object which has multiple representation (JSON, plain HTML
    -- etc). Each client might have a preference on which format it wants
    -- the abstract object in. For example, a javascript making a request
    -- (on behalf of a browser) might prefer a JSON object over a plain
    -- HTML file where as a user browsing with javascript disabled would
    -- want the page in HTML. The third argument is a function that
    -- converts the abstract object to the desired representation
    -- depending on the preferences sent by the client.
    --
    -- The typical values for the first three arguments are,
    -- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and
    -- @fmap 'chooseRep'@.

    mkDispatchClause :: MkDispatchSettings
                     -> [ResourceTree a]
                     -> Q Clause
    mkDispatchClause mds ress' = do
        -- Allocate the names to be used. Start off with the names passed to the
        -- function itself (with a 0 suffix).
        --
        -- We don't reuse names so as to avoid shadowing names (triggers warnings
        -- with -Wall). Additionally, we want to ensure that none of the code
        -- passed to toDispatch uses variables from the closure to prevent the
        -- dispatch data structure from being rebuilt on each run.
        getEnv0 <- newName "yesod_dispatch_env0"
        req0 <- newName "req0"
        pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|]

        -- Name of the dispatch function
        dispatch <- newName "dispatch"

        -- Dispatch function applied to the pieces
        let dispatched = VarE dispatch `AppE` pieces

        -- The 'D.Route's used in the dispatch function
        routes <- mapM (buildRoute mds) ress

        -- The dispatch function itself
        toDispatch <- [|D.toDispatch|]
        let dispatchFun = FunD dispatch
                [Clause
                    []
                    (NormalB $ toDispatch `AppE` ListE routes)
                    []
                ]

        -- The input to the clause.
        let pats = map VarP [getEnv0, req0]

        -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
        methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress

        u <- [|case $(return dispatched) of
                Just f -> f $(return $ VarE getEnv0)
                            $(return $ VarE req0)
                Nothing -> $(mdsRunHandler mds)
                                $(mds404 mds)
                                $(return $ VarE getEnv0)
                                Nothing
                                $(return $ VarE req0)
              |]
        return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
      where
        ress = flatten ress'

    -- | Determine the name of the method map for a given resource name.
    methodMapName :: String -> Name
    methodMapName s = mkName $ "methods" ++ s

    buildMethodMap :: MkDispatchSettings
                   -> FlatResource a
                   -> Q (Maybe Dec)
    buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
    buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do
        fromList <- [|Map.fromList|]
        methods' <- mapM go methods
        let exp = fromList `AppE` ListE methods'
        let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
        return $ Just fun
      where
        pieces = concat $ map snd parents ++ [pieces']
        go method = do
            func <- mdsGetHandler mds (Just method) name
            pack' <- [|encodeUtf8 . pack|]
            let isDynamic Dynamic{} = True
                isDynamic _ = False
            let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
            xs <- replicateM argCount $ newName "arg"
            runHandler <- mdsRunHandler mds
            let rhs
                    | null xs = runHandler `AppE` func
                    | otherwise =
                        LamE (map VarP xs) $
                        runHandler `AppE` (foldl' AppE func $ map VarE xs)
            return $ TupE
                [ pack' `AppE` LitE (StringL method)
                , rhs
                ]
    buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing

    -- | Build a single 'D.Route' expression.
    buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp
    buildRoute mds (FlatResource parents name resPieces resDisp) = do
        -- First two arguments to D.Route
        routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
        isMulti <-
            case resDisp of
                Methods Nothing _ -> [|False|]
                _ -> [|True|]

        [|D.Route
            $(return routePieces)
            $(return isMulti)
            $(routeArg3
                mds
                parents
                name
                (map snd allPieces)
                resDisp)
            |]
      where
        allPieces = concat $ map snd parents ++ [resPieces]

    routeArg3 :: MkDispatchSettings
              -> [(String, [(CheckOverlap, Piece a)])]
              -> String -- ^ name of resource
              -> [Piece a]
              -> Dispatch a
              -> Q Exp
    routeArg3 mds parents name resPieces resDisp = do
        pieces <- newName "pieces"

        -- Allocate input piece variables (xs) and variables that have been
        -- converted via fromPathPiece (ys)
        xs <- forM resPieces $ \piece ->
            case piece of
                Static _ -> return Nothing
                Dynamic _ -> Just <$> newName "x"

        -- Note: the zipping with Ints is just a workaround for (apparently) a bug
        -- in GHC where the identifiers are considered to be overlapping. Using
        -- newName should avoid the problem, but it doesn't.
        ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
            y <- newName $ "y" ++ show (i :: Int)
            return (x, y)

        -- In case we have multi pieces at the end
        xrest <- newName "xrest"
        yrest <- newName "yrest"

        -- Determine the pattern for matching the pieces
        pat <-
            case resDisp of
                Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
                _ -> do
                    let cons = mkName ":"
                    return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs

        -- Convert the xs
        fromPathPiece' <- [|fromPathPiece|]
        xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)

        -- Convert the xrest if appropriate
        (reststmts, yrest') <-
            case resDisp of
                Methods (Just _) _ -> do
                    fromPathMultiPiece' <- [|fromPathMultiPiece|]
                    return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
                _ -> return ([], [])

        -- The final expression that actually uses the values we've computed
        caller <- buildCaller mds xrest parents name resDisp $ map snd ys ++ yrest'

        -- Put together all the statements
        just <- [|Just|]
        let stmts = concat
                [ xstmts
                , reststmts
                , [NoBindS $ just `AppE` caller]
                ]

        errorMsg <- [|error "Invariant violated"|]
        let matches =
                [ Match pat (NormalB $ DoE stmts) []
                , Match WildP (NormalB errorMsg) []
                ]

        return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches

    -- | The final expression in the individual Route definitions.
    buildCaller :: MkDispatchSettings
                -> Name -- ^ xrest
                -> [(String, [(CheckOverlap, Piece a)])]
                -> String -- ^ name of resource
                -> Dispatch a
                -> [Name] -- ^ ys
                -> Q Exp
    buildCaller mds xrest parents name resDisp ys = do
        getEnv <- newName "yesod_dispatch_env"
        req <- newName "req"

        method <- [|$(mdsMethod mds) $(return $ VarE req)|]

        let pat = map VarP [getEnv, req]

        -- Create the route
        let route = routeFromDynamics parents name ys

        exp <-
            case resDisp of
                Methods _ ms -> do
                    handler <- newName "handler"

                    env <- [|$(return $ VarE getEnv) (Just $(return route))|]

                    -- Run the whole thing
                    runner <- [|$(return $ VarE handler)
                                    $(return $ VarE getEnv)
                                    (Just $(return route))
                                    $(return $ VarE req)
                                    |]

                    let myLet handlerExp =
                            LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner

                    if null ms
                        then do
                            -- Just a single handler
                            base <- mdsGetHandler mds Nothing name
                            let he = foldl' (\a b -> a `AppE` VarE b) base ys
                            runHandler <- mdsRunHandler mds
                            return $ myLet $ runHandler `AppE` he
                        else do
                            -- Individual methods
                            mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|]
                            f <- newName "f"
                            let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
                            body405 <-
                                [|$(mdsRunHandler mds)
                                    $(mds405 mds)
                                    $(return $ VarE getEnv)
                                    (Just $(return route))
                                    $(return $ VarE req)
                                 |]
                            return $ CaseE mf
                                [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
                                , Match (ConP 'Nothing []) (NormalB body405) []
                                ]

                Subsite _ getSub -> do
                    sub <- newName "sub"
                    let sub2 = LamE [VarP sub]
                            (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)
                    [|$(mdsSubDispatcher mds)
                        $(mdsRunHandler mds)
                        $(return sub2)
                        $(return route)
                        $(return $ VarE getEnv)
                        ($(mdsSetPathInfo mds)
                            $(return $ VarE xrest)
                            $(return $ VarE req)
                            )
                     |]

        return $ LamE pat exp

    -- | Convert a 'Piece' to a 'D.Piece'
    convertPiece :: Piece a -> Q Exp
    convertPiece (Static s) = [|D.Static (pack $(lift s))|]
    convertPiece (Dynamic _) = [|D.Dynamic|]

    routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
                      -> String -- ^ constructor name
                      -> [Name]
                      -> Exp
    routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
    routeFromDynamics ((parent, pieces):rest) name ys =
        foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
      where
        (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
        isDynamic Dynamic{} = True
        isDynamic _ = False
        here = map VarE here' ++ [routeFromDynamics rest name ys']