DoAndIfThenElse
, ExistentialQuantification
, FlexibleInstances
+ , GeneralizedNewtypeDeriving
, OverlappingInstances
, MultiParamTypeClasses
, RecordWildCards
, ScopedTypeVariables
+ , TemplateHaskell
, UndecidableInstances
, UnicodeSyntax
#-}
, ResourceMapper(..)
, ResourceMap
, ResourceTree
- , ResourceNode
, dispatch
)
import Control.Monad.Trans.Maybe
import Control.Monad.Unicode
import Data.Collections
-import qualified Data.Map as M
+import qualified Data.Collections.Newtype.TH as C
import Data.Monoid
import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Dispatcher.Node
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
-import Prelude hiding (filter, lookup, null)
+import Prelude hiding (lookup)
import Prelude.Unicode
-- |FIXME: docs
-- FIXME: doc
newtype ResourceTree = Root ResourceNode
-
--- FIXME: docs
-data ResourceNode
- = Greedy !Resource
- | NonGreedy !Resource !ResourceTree
- | Branch !ResourceTree
+ deriving (Monoid, Show)
-- Instances of SchemeMapper --------------------------------------------------
instance SchemeMapper SchemeMap where
{-# INLINE singleton #-}
singleton = schemeMap
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid SchemeMap where
{-# INLINE mempty #-}
mempty = schemeMap e
{-# INLINE singleton #-}
singleton = hostMap
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid HostMap where
{-# INLINE mempty #-}
mempty = hostMap e
{-# INLINE singleton #-}
singleton = resourceMap
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid ResourceMap where
{-# INLINE mempty #-}
mempty = resourceMap e
findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
-- Instances of ResourceTree --------------------------------------------------
-{-
-instance (Functor m, MonadIO m)
- ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where
- {-# INLINE insert #-}
- insert e (Root root) = Root $ insert e root
- {-# INLINE empty #-}
- empty = (∅)
-
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where
- {-# INLINE mempty #-}
- mempty = Root (∅)
- {-# INLINE mappend #-}
- mappend (Root a) (Root b)
- = Root (a ⊕ b)
--}
-
--- Instances of ResourceNode --------------------------------------------------
-{-
-instance (Functor m, MonadIO m)
- ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where
- {-# INLINEABLE insert #-}
- insert (p, a) b = insertNodeAt (canonPath p) a b
- {-# INLINE empty #-}
- empty = Branch (∅)
-
-canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
-{-# INLINEABLE canonPath #-}
-canonPath = filter ((¬) ∘ null)
-
-insertNodeAt ∷ (Functor m, MonadIO m)
- ⇒ [PathSegment]
- → ResourceNode m
- → ResourceNode m
- → ResourceNode m
-{-# INLINEABLE insertNodeAt #-}
-insertNodeAt [] a b = a ⊕ b
-insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b
-insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b
-
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
- {-# INLINE mempty #-}
- mempty = Branch (∅)
- {-# INLINEABLE mappend #-}
- mappend _ (Greedy r ) = Greedy r
- mappend (Greedy _ ) (NonGreedy r n) = NonGreedy r n
- mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
- mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
- mappend (Greedy r ) (Branch _) = Greedy r
- mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
- mappend (Branch m) (Branch n) = Branch (m ⊕ n)
--}
+C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
+ |]
-- dispatch -------------------------------------------------------------------
dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)