{-# LANGUAGE LambdaCase, KindSignatures, DataKinds, ScopedTypeVariables, OverloadedStrings, TypeOperators, FlexibleInstances #-}

import           Control.Applicative
import           Data.Proxy
import qualified Data.Text as Text
import           Data.Text (Text)
import           GHC.TypeLits
import           Network.Wai

-- For sanity (see later)
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap

type Segment = Text

type Path = [ Segment ]

-- Application with the current path included.
type RoutingApplication = Path -> Application

-- Given the router type and a path,
-- return a function that will perform the routing if applicable.
class Router r where
  route :: proxy r -> Path -> Maybe (r -> RoutingApplication)

type f :> g = f g
infixr 1 :>

newtype Raw = Raw Application

instance Router Raw where
  route _ _ = Just $ \(Raw app) _ -> app

newtype Dir (seg :: Symbol) a = Dir a

type seg /> g = Dir seg :> g
infixr 1 />

instance (KnownSymbol seg, Router next) => Router (seg /> next) where
  route _ = \case
    s : segs | Text.unpack s == symbolVal (Proxy :: Proxy seg)
      -> route (Proxy :: Proxy next) segs <&> \nextRouter (Dir next) (_ : segs) -> nextRouter next segs
    _ -> Nothing

-- Try to route with r1, or try to route with r2.
data r1 :<|> r2
  = r1 :<|> r2

infixr 0 :<|>

instance (Router r1, Router r2) => Router (r1 :<|> r2) where
  route _ path
    = routeLeft <|> routeRight
      where
        routeLeft = route (Proxy :: Proxy r1) path <&> \r1Router (r1 :<|> r2) -> r1Router r1
        routeRight = route (Proxy :: Proxy r2) path <&> \r2Router (r1 :<|> r2) -> r2Router r2

-- Capture a segment and pass it on.
newtype Capture next = Capture (Segment -> next)

instance Router next => Router (Capture next) where
  route _ (_ : segs)
    = route (Proxy :: Proxy a) segs <&> \nextRouter (Capture f) (seg : segs) -> nextRouter (f seg) segs

-- Type operators

-- Example

type Benaco
  =    "foo" /> Raw
  :<|> Capture :> "baz" /> Raw

benacoImpl :: Benaco
benacoImpl
  =      (Dir $ Raw someApp)
    :<|> Capture (\foo -> Dir $ Raw someApp)
  where
    someApp :: Application
    someApp = undefined