{-# LANGUAGE
    ExistentialQuantification
  , FlexibleInstances
  , MultiParamTypeClasses
  , UndecidableInstances
  , UnicodeSyntax
  #-}
-- |FIXME: doc
module Network.HTTP.Lucu.Resource.Dispatcher
    ( Dispatchable(..)
    , Dispatcher
    , uriHost
    , uriPathSegments
    )
    where
import Data.CaseInsensitive (CI)
import Data.Collections
import Data.Monoid
import Data.Text (Text)
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI
import Prelude.Unicode

-- |FIXME: docs
--
-- Minimal complete definition: 'dispatch'
class Dispatchable α where
    dispatch ∷ α → URI → IO (Maybe Resource)

    dispatcher ∷ α → Dispatcher
    {-# INLINE dispatcher #-}
    dispatcher = Dispatcher

-- |Container type for 'Dispatchable' type class.
data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α

instance Dispatchable Dispatcher where
    dispatch (Dispatcher α) = dispatch α
    dispatcher = id

-- |@insert a b@ first tries @a@, and then tries @b@. @insertMany bs
-- a@ first tries @a@, and then tries each one in @bs@ from head to
-- tail.
instance Dispatchable α ⇒ Unfoldable Dispatcher α where
    {-# INLINEABLE insert #-}
    insert a (Dispatcher b)
        = dispatcher
          $ \uri → do r ← dispatch a uri
                      case r of
                        Just _  → return r
                        Nothing → dispatch b uri
    {-# INLINE empty #-}
    empty = dispatcher e
        where
          e ∷ URI → IO (Maybe Resource)
          {-# INLINE e #-}
          e = return ∘ const Nothing
    {-# INLINE singleton #-}
    singleton = dispatcher

-- |@a `'mappend'` b@ first tries @a@, and then tries @b@.
instance Monoid Dispatcher where
    {-# INLINE mempty #-}
    mempty = empty
    {-# INLINE mappend #-}
    mappend = insert

-- |An IO-based dispatcher.
instance Dispatchable (URI → IO (Maybe Resource)) where
    dispatch = id

-- |A pure dispatcher.
instance Dispatchable (URI → Maybe Resource) where
    dispatch = (return ∘)

-- |The constant dispatcher returning always the same 'Resource'.
instance Dispatchable Resource where
    dispatch = const ∘ return ∘ Just

-- |FIXME: doc
uriHost ∷ URI → CI Text
uriHost = error "FIXME"