X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRouter.hs;fp=Network%2FHTTP%2FLucu%2FRouter.hs;h=f04441baf0b8fbdf9b40b0f69d87bbc3c25dd0d4;hb=1a8b40bc467928dc018f00a3899cbc39398b213e;hp=0000000000000000000000000000000000000000;hpb=96f818ba94c45e04ff29a1c03fb2d1a9ebd97f62;p=Lucu.git

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)