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

[Lucu.git] / Network / HTTP / Lucu / Router.hs

diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
new file mode 100644 (file)
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)