DoAndIfThenElse
, ExistentialQuantification
, FlexibleInstances
+ , GeneralizedNewtypeDeriving
, OverlappingInstances
, MultiParamTypeClasses
, RecordWildCards
, ScopedTypeVariables
+ , TemplateHaskell
, UndecidableInstances
, UnicodeSyntax
#-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Network.HTTP.Lucu.Dispatcher.Internal
( SchemeMapper(..)
, SchemeMap
-- |Container type for the 'ResourceMapper' type class.
data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
--- FIXME: doc
+-- |FIXME: doc
newtype ResourceTree = Root ResourceNode
+ deriving (Monoid, Show)
--- FIXME: docs
+-- |FIXME: docs
data ResourceNode
= Greedy !Resource
- | NonGreedy !Resource !ResourceTree
- | Branch !ResourceTree
+ | NonGreedy !Resource !SubTree
+ | Branch !SubTree
+
+type SubTree
+ = M.Map PathSegment ResourceNode
-- 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 mappend #-}
mappend = insert
+-- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
instance Map α Scheme HostMap ⇒ SchemeMapper α where
{-# INLINE findHostMap #-}
findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
{-# 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 mappend #-}
mappend = insert
+-- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
instance Map α Host ResourceMap ⇒ HostMapper α where
{-# INLINE findResourceMap #-}
findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
{-# 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
{-# INLINE mappend #-}
mappend = insert
+-- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
+-- are also 'ResourceMapper's.
instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
{-# INLINE findResource #-}
findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
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
+instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
{-# INLINEABLE insert #-}
- insert (p, a) b = insertNodeAt (canonPath p) a b
+ insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
{-# INLINE empty #-}
- empty = Branch (∅)
+ empty = Root $ 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
+insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
{-# 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
+insertNodeAt p a b
+ = case front p of
+ Nothing → a ⊕ b
+ Just (x, xs)
+ | null xs → Branch (singleton (x, a)) ⊕ b
+ | otherwise → insertNodeAt xs a (∅) ⊕ b
+
+instance Foldable ResourceTree (PathSegments, ResourceNode) where
+ foldMap f (Root n) = go (∅) n
+ where
+ go p (Greedy r ) = f (p, Greedy r)
+ go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m
+ go p (Branch m) = go' p m
+
+ go' p = foldMap $ \(s, n') → go (p `snoc` s) n'
+
+ null (Root (Greedy _ )) = False
+ null (Root (NonGreedy _ _)) = False
+ null (Root (Branch m)) = null m
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
+
+-- Instances of ResourceNode --------------------------------------------------
+instance Show ResourceNode where
+ show (Greedy _ ) = "Greedy _"
+ show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m
+ show (Branch m) = "Branch " ⊕ show m
+
+instance Monoid ResourceNode 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 (Greedy r ) _ = Greedy r
+ mappend (NonGreedy r m) (Greedy _ ) = NonGreedy r m
+ mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
+ mappend (Branch _) (Greedy r ) = Greedy r
+ mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
mappend (Branch m) (Branch n) = Branch (m ⊕ n)
--}
-- dispatch -------------------------------------------------------------------
dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
projects / Lucu.git / blobdiff