{-# LANGUAGE OverlappingInstances, FunctionalDependencies, ScopedTypeVariables,
    MultiParamTypeClasses, FlexibleInstances, UndecidableInstances,
    FlexibleContexts, DeriveFunctor #-}
{-# OPTIONS_HADDOCK hide #-}

module Happstack.StaticRouting.Internal where

import Happstack.Server(askRq, rqPaths, rqMethod, localRq, ServerMonad,
  HasRqData, methodM, look, FromReqURI)
import qualified Happstack.Server as H
import Control.Monad(msum, MonadPlus, mzero, mplus)
import Control.Monad.IO.Class(MonadIO)
import Control.Arrow(first, second)
import qualified Data.ListTrie.Map as Trie
import Data.Map(Map)
import qualified Data.Map as Map
import Data.List(intercalate)
import Data.Maybe

-- | Static routing tables consisting of handlers of type 'a'.
data Route a =
    Dir Segment (Route a)
  | Handler EndSegment a
  | Param String (Route a)
  | Choice [Route a]
  deriving Functor

-- For backwards compatibility with GHC 6.12
handler :: EndSegment -> a -> Route a
handler = Handler

newtype Segment =
    StringS String
  deriving (Show, Eq, Ord)

type EndSegment = (Maybe Int, H.Method)

-- | Support for varying number of arguments to 'path' handlers.
class Path m hm a b | a b -> m hm where
  pathHandler :: (m b -> hm c) -> a -> hm c
  arity :: m b -> a -> Int

instance (FromReqURI d, ServerMonad hm, MonadPlus hm, Path m hm a b)
         => Path m hm (d -> a) b where
  pathHandler w f = H.path (pathHandler w . f)
  arity m f = 1 + arity m (f undefined)

instance Path m hm (m b) b where
  pathHandler w m = w m
  arity _ _ = 0

-- | Pop a path element if it matches the given string.
dir :: String -> Route a -> Route a
dir = Dir . StringS

-- | Combine several route alternatives into one.
choice :: [Route a] -> Route a
choice = Choice

-- | Expect the given method, and exactly 'n' more segments, where 'n' is the arity of the handler.
path :: forall m hm h a b. Path m hm h a => H.Method -> (m a -> hm b) -> h -> Route (hm b)
path m w h = Handler (Just (arity (undefined::m a) h),m) (pathHandler w h)

-- | Expect zero or more segments.
remainingPath :: H.Method -> h -> Route h
remainingPath m = Handler (Nothing,m)

-- | DEPRECATED. Expect a specific parameter to be present.
param :: String -> Route a -> Route a
param = Param

-- | Extract handler monad from a route.
extract :: (ServerMonad m, MonadPlus m, HasRqData m, MonadIO m) => Route (m a) -> m a
extract = f Nothing where
  f p (Dir (StringS s) r) = H.dir s (f p r)
  f (Just p) (Param p' _) = error $ "extract: cannot handle more than one param: "++ show(p,p')
  f _ (Param p r) = f (Just p) r
  f p (Handler (_,m) a) = doParam p >> methodM m >> a
  f p (Choice rs) = msum (map (f p) rs)

doParam :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>
           Maybe String -> m ()
doParam Nothing = return ()
doParam (Just p) = H.getDataFn (look p) >>= either (const mzero) (const (return ()))

type Param = Maybe String
newtype RouteTree a =
  R { unR :: Trie.TrieMap Map Segment (Map EndSegment (Map Param [a])) } deriving (Show)

type Segments = ([Segment],EndSegment)

routeTree :: (ServerMonad m, MonadPlus m) => Route (m a) -> RouteTree (m a)
routeTree r = R $ foldr (\(((ps,es),mp),m) ->
                          Trie.insertWith (Map.unionWith (Map.unionWith (++)))
                              ps
                              (Map.singleton es (Map.singleton mp [m])))
                  Trie.empty (flatten r)

flatten :: (ServerMonad m, MonadPlus m) => Route (m a) -> [((Segments, Param), m a)]
flatten = f Nothing where
  f p (Dir s r) = map (first (first (first (s:)))) (f p r)
  f (Just p) (Param p' _) = error $ "flatten: cannot handle more than one param: "++show (p,p')
  f _ (Param p' r) = f (Just p') r
  f p (Handler e a) = [((([], e),p), a)]
  f p (Choice rs) = concatMap (f p) rs

-- | Compile routes, also return possible overlap report.  If the
-- overlap report is 'Nothing', the routing table is order
-- independent.  If the overlap report is @Just s@, then @s@ is a
-- textual representation of all the paths that are order dependent,
-- suitable for a warning message.
compile :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>
           Route (m a) -> (m a, Maybe String)
compile r = ( dispatch t
            , if null os then Nothing
              else Just $ "Overlapping handlers: \n"++ showOverlaps os
            )
  where t = routeTree r
        os = overlaps True t

maybezero :: MonadPlus m => Maybe a -> (a -> m b) -> m b
maybezero = flip (maybe mzero)

-- | Dispatch a request given a route.  Give priority to more specific paths
-- in case of overlap.
dispatch :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>
            RouteTree (m a) -> m a
dispatch (R t) = do
  let m = Trie.children1 t
  rq  <- askRq
  let ps = rqPaths rq
  (case ps of
      p:xs -> maybezero (Map.lookup (StringS p) m)
                        (localRq (\newRq -> newRq{rqPaths = xs}) . dispatch . R)
      []   -> mzero)
    -- most specific: match against a given next segment
    `mplus`
    (maybezero (Trie.lookup [] t) $ \em ->
     maybezero (Map.lookup (Just (length ps), rqMethod rq) em) dispatchParams
    -- or else a 'path' taking a given specific number of remaining segments
     `mplus`
     maybezero (Map.lookup (Nothing, rqMethod rq) em) dispatchRemainingPath
     -- least specific: a 'remainingPath' taking any number of remaining segments
     )


-- We want first to handle ones with params
dispatchParams :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>
                  Map (Maybe String) [m a] -> m a
dispatchParams m = let
                    (paramfull,paramless) = Map.partitionWithKey (const . isJust) m
                   in msum $ [doParam p >> msum hs | (p,hs) <- Map.assocs paramfull] ++ [msum hs | (Nothing,hs) <- Map.assocs paramless]

dispatchRemainingPath :: MonadPlus m => Map k [m a] -> m a
dispatchRemainingPath m = msum (map msum (Map.elems m))

-- | All paths with more than one handler.
overlaps :: forall a .
            Bool -- ^ Only include order-dependent paths (exclude paths overlapping with more specific paths)
         -> RouteTree a -> [[([Segment],[(EndSegment,[(Param,[a])])])]]
overlaps eso t = (filter (not . null) $
                  map (filter (not . null . snd) . (:[]) . second f) $
                  flattenTree t) ++
                 if eso then [] else  pathOverlaps t
  where f :: [(EndSegment,[(Param,[a])])] -> [(EndSegment,[(Param,[a])])]
        f l = (filter (not . null . snd) . map (second g)) l
        g l@((Nothing,_):_:_) | not eso = l  -- non-parameter handler overlaps with parameter handlers
        g l = filter ((>1) . length . snd) l -- more than one handler for this path

pathOverlaps :: RouteTree a -> [[([Segment], [(EndSegment, [(Param, [a])])])]]
pathOverlaps (R t) =
  (case Trie.lookup [] t of
    Just em -> filter ((>1) . length) $ map f (Map.keys em)
      where f es1 = filter ((>0) . length . snd)
                    [ (ks, filter (lengthOverlaps es1 (length ks)) as)
                    | (ks,as) <- flattenTree (R t) ]
            lengthOverlaps (a1,m1) ksl ((a2,m2),_) =
              m1 == m2 && case (a1,a2) of
                            (Nothing,_) -> True
                            (Just i1,Nothing) -> i1 >= ksl
                            (Just i1,Just i2) -> i1 == ksl + i2

    Nothing -> []) ++
  [ [ (k:ks,a) | (ks,a) <- l ]
  | (k,t') <- Map.assocs (Trie.children1 t)
  , l <- pathOverlaps (R t') ]

showOverlaps :: [[([Segment],[(EndSegment,[(Param,[a])])])]] -> String
showOverlaps = unlines . intercalate [[]] . map (concatMap showPath)

showPath :: ([Segment],[(EndSegment,[(Param,[a])])]) -> [String]
showPath (ss,es) =
  [ intercalate "/" (map showSegment ss++
                     showArity i)++
                     showParam p++showMethod m++
                     showHandlers hs
  | ((i,m),ps) <- es, (p,hs) <- ps ]
  where showParam Nothing  = ""
        showParam (Just p) = "?"++p++"=*"
        showMethod H.GET = ""
        showMethod m = " ("++show m++")"
        showSegment (StringS s) = s
        showArity Nothing = ["**"]
        showArity (Just i) = replicate i "*"
        showHandlers hs | length hs == 1 = ""
                        | otherwise      = " -> "++show (length hs)

-- | Convert to a list of path-value pairs.
flattenTree :: RouteTree a -> [([Segment],[(EndSegment,[(Param,[a])])])]
flattenTree (R t) =
  (case Trie.lookup [] t of
     Just em -> [([], map (second Map.assocs) (Map.assocs em))]
     Nothing -> []) ++
  [ (k:ks,a) | (k,t') <- Map.assocs (Trie.children1 t)
             , (ks,a) <- flattenTree (R t') ]