From: PHO <pho@cielonegro.org>
Date: Fri, 6 Jan 2012 03:46:37 +0000 (+0900)
Subject: New module Network.HTTP.Lucu.Router (mostly a stub for now)
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=1a8b40bc467928dc018f00a3899cbc39398b213e;p=Lucu.git

New module Network.HTTP.Lucu.Router (mostly a stub for now)

Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d
---

diff --git a/Lucu.cabal b/Lucu.cabal
index 3afe50b..6cbb16a 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -50,6 +50,7 @@ Flag ssl
 
 Library
     Build-Depends:
+        arrow-list                 == 0.2.*,
         ascii                      == 0.0.*,
         attempt                    == 0.3.*,
         attoparsec                 == 0.10.*,
@@ -113,6 +114,7 @@ Library
         Network.HTTP.Lucu.Resource
         Network.HTTP.Lucu.Response
         Network.HTTP.Lucu.Response.StatusCode
+        Network.HTTP.Lucu.Router
         Network.HTTP.Lucu.SocketLike
         Network.HTTP.Lucu.StaticFile
         Network.HTTP.Lucu.Utils
diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
new file mode 100644
index 0000000..f04441b
--- /dev/null
+++ b/Network/HTTP/Lucu/Router.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE
+    GeneralizedNewtypeDeriving
+  , UnicodeSyntax
+  #-}
+-- |FIXME: doc
+module Network.HTTP.Lucu.Router
+    ( Router
+    , runRouter
+    )
+    where
+import Control.Applicative
+import Control.Category
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowKleisli
+import Control.Arrow.List
+import Control.Monad.IO.Class
+import Control.Monad.Unicode
+import Prelude.Unicode
+
+-- |FIXME: doc
+newtype MonadIO m ⇒ Router m α β
+    = Router {
+        unRouter ∷ ListTArrow m α β
+      }
+    deriving ( Arrow
+             , ArrowKleisli m
+             , ArrowZero
+             , ArrowList
+             , ArrowPlus
+             , ArrowChoice
+             , ArrowApply
+             , Category
+             )
+
+-- |FIXME: doc
+runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
+{-# INLINEABLE runRouter #-}
+runRouter = ((optional' =≪) ∘) ∘ runListTArrow ∘ unRouter
+    where
+      optional' ∷ Applicative f ⇒ [β] → f (Maybe β)
+      {-# INLINE optional' #-}
+      optional' []    = pure Nothing
+      optional' (x:_) = pure (Just x)