Merge pull request #3 from ambroslins/list-instance

Add a ToServer instance for lists
anton-k · Oct 16, 2023 · 2b90c14 · 2b90c14
2 parents 076f8dd + b366507
commit 2b90c14
Show file tree

Hide file tree

Showing 12 changed files with 85 additions and 79 deletions.
diff --git a/docs/src/01-hello-world.md b/docs/src/01-hello-world.md
@@ -298,6 +298,18 @@ to the value `Server m`. So we have the flexibility on DSL level but
 on the level of implementation to build the tree of handlers we use the same type.
 which makes type very simple.
 
+### List instance for Servers
+Because of the `ToServer a => ToServer [a]` instance we can omit the `mconcat`
+most of the time. Meaning we can write the previous examples as:
+
+```haskell
+server = 
+  "api/v1/hello" /.
+      [ toServer helloGet
+      , toServer helloPost
+      ]
+```
+
 ### The path type
 
 Let's discuss the `Path` type.

diff --git a/docs/src/02-request-anatomy.md b/docs/src/02-request-anatomy.md
@@ -272,8 +272,7 @@ main = runServer 8085 server
 -- | Let's define a server
 server :: Server IO
 server = 
-  "api"
-  /. mconcat
+  "api" /.
     -- no args, constnat output
     [ "hello/world" /. helloWorld
     , -- required query param and custom header
@@ -387,8 +386,7 @@ Let's add a swagger to our server. Just add this line:
 server :: IO
 server = 
   withSwagger def $ 
-    "api" /. 
-      mcomcat [ {- the rest of the code -} ]
+    "api" /. [ {- the rest of the code -} ]
 ```
 
 Let's add this line to our example and restart the server.

diff --git a/docs/src/04-other-monads.md b/docs/src/04-other-monads.md
@@ -116,10 +116,9 @@ Our server has two routes:
 server :: Server App
 server =
   "counter"
-    /. mconcat
-      [ "get" /. handleGet
-      , "put" /. handlePut
-      ]
+    /. [ "get" /. handleGet
+       , "put" /. handlePut
+       ]
 ```
 Let's define the `get` route:
 

diff --git a/docs/src/06-json-api-example.md b/docs/src/06-json-api-example.md
@@ -98,10 +98,9 @@ server :: Env -> Server IO
 server env =
   withSwagger def $
     "api/v1/weather"
-      /. mconcat
-        [ auth
-        , withAuth env $: app
-        ]
+      /. [ auth
+         , withAuth env $: app
+         ]
   where
     auth = "get/auth-token" /. requestAuthToken env
 

diff --git a/docs/src/07-blog-post-example.md b/docs/src/07-blog-post-example.md
@@ -97,10 +97,9 @@ server site =
   logRoutes $
     mconcat
       [ "blog"
-          /. mconcat
-            [ readServer
-            , writeServer
-            ]
+          /. [ readServer
+             , writeServer
+             ]
       , defaultPage
       , addFavicon $ "static" /. staticFiles resourceFiles
       ]
@@ -145,10 +144,9 @@ Let's define read-only pages for our site.
 readServer =
   mconcat
     [ "read"
-        /. mconcat
-          [ "post" /. handleBlogPost site
-          , "quote" /. handleQuote site
-          ]
+        /. [ "post" /. handleBlogPost site
+           , "quote" /. handleQuote site
+           ]
     , "list" /. handleListPosts site
     ]
 
@@ -173,10 +171,9 @@ Let's define a route to add new blog posts to the site:
     -- server to write new blog posts
     writeServer =
       "write"
-        /. mconcat
-          [ toServer $ handleWriteForm site
-          , toServer $ handleWriteSubmit site
-          ]
+        /. [ toServer $ handleWriteForm site
+           , toServer $ handleWriteSubmit site
+           ]
 
 handleWriteForm :: Site -> Get (Page WritePost)
 

diff --git a/examples/mig-example-apps/Counter/Main.hs b/examples/mig-example-apps/Counter/Main.hs
@@ -57,10 +57,9 @@ initEnv = Env <$> newIORef 0
 server :: Server App
 server =
   "counter"
-    /. mconcat
-      [ "get" /. handleGet
-      , "put" /. handlePut
-      ]
+    /. [ "get" /. handleGet
+       , "put" /. handlePut
+       ]
 
 -- | Get handler. It logs the call and returns current state
 handleGet :: Get App (Resp Int)

diff --git a/examples/mig-example-apps/Html/src/Server.hs b/examples/mig-example-apps/Html/src/Server.hs
@@ -24,10 +24,9 @@ server site =
   logRoutes $
     mconcat
       [ "blog"
-          /. mconcat
-            [ readServer
-            , writeServer
-            ]
+          /. [ readServer
+             , writeServer
+             ]
       , defaultPage
       , addFavicon $ "static" /. staticFiles resourceFiles
       ]
@@ -37,7 +36,7 @@ server site =
     -- server to read info.
     -- We can read blog posts and quotes.
     readServer =
-      mconcat
+      toServer
         [ "read"
             /. mconcat
               [ "post" /. handleBlogPost site
@@ -49,14 +48,13 @@ server site =
     -- server to write new blog posts
     writeServer =
       "write"
-        /. mconcat
-          [ toServer $ handleWriteForm site
-          , toServer $ handleWriteSubmit site
-          ]
+        /. [ toServer $ handleWriteForm site
+           , toServer $ handleWriteSubmit site
+           ]
 
     -- default main page
     defaultPage =
-      mconcat
+      toServer
         [ "/" /. handleGreeting site
         , "index.html" /. handleGreeting site
         ]

diff --git a/examples/mig-example-apps/JsonApi/Server.hs b/examples/mig-example-apps/JsonApi/Server.hs
@@ -20,15 +20,14 @@ server env =
   setSwagger $
     withTrace $
       "api/v1/weather"
-        /. mconcat
-          [ auth
-          , withAuth env $: app
-          ]
+        /. [ auth
+           , withAuth env $: app
+           ]
   where
     auth = "get/auth-token" /. requestAuthToken env
 
     app =
-      mconcat
+      toServer
         [ "get/weather" /. getWeather env
         , "update" /. updateWeather env
         ]

diff --git a/examples/mig-example-apps/RouteArgs/Main.hs b/examples/mig-example-apps/RouteArgs/Main.hs
@@ -23,24 +23,24 @@ routeArgs =
   withSwagger def $
     withTrace $
       "api"
-        /. mconcat
-          -- no args, constnat output
-          [ "hello/world" /. helloWorld
-          , -- required query param and custom header
-            "succ" /. handleSucc
-          , -- optional query param
-            "succ-opt" /. handleSuccOpt
-          , -- several query params
-            "add" /. handleAdd
-          , -- query flag
-            "add-if" /. handleAddIf
-          , -- capture
-            "mul" /. handleMul
-          , -- json body as input
-            "add-json" /. handleAddJson
-          , -- return error
-            "square-root" /. handleSquareRoot
-          ]
+        /.
+        -- no args, constnat output
+        [ "hello/world" /. helloWorld
+        , -- required query param and custom header
+          "succ" /. handleSucc
+        , -- optional query param
+          "succ-opt" /. handleSuccOpt
+        , -- several query params
+          "add" /. handleAdd
+        , -- query flag
+          "add-if" /. handleAddIf
+        , -- capture
+          "mul" /. handleMul
+        , -- json body as input
+          "add-json" /. handleAddJson
+        , -- return error
+          "square-root" /. handleSquareRoot
+        ]
   where
     withTrace = applyMiddleware (Trace.logHttp Trace.V2)
 

diff --git a/examples/mig-example-apps/RouteArgsClient/Main.hs b/examples/mig-example-apps/RouteArgsClient/Main.hs
@@ -82,24 +82,24 @@ helloWorld
 server :: Server Client
 server =
   "api"
-    /. mconcat
-      -- no args, constnat output
-      [ "hello/world" /. helloWorld
-      , -- required query param and custom header
-        "succ" /. handleSucc
-      , -- optional query param
-        "succ-opt" /. handleSuccOpt
-      , -- several query params
-        "add" /. handleAdd
-      , -- query flag
-        "add-if" /. handleAddIf
-      , -- capture
-        "mul" /. handleMul
-      , -- json body as input
-        "add-json" /. handleAddJson
-      , -- return error
-        "square-root" /. handleSquareRoot
-      ]
+    /.
+    -- no args, constnat output
+    [ "hello/world" /. helloWorld
+    , -- required query param and custom header
+      "succ" /. handleSucc
+    , -- optional query param
+      "succ-opt" /. handleSuccOpt
+    , -- several query params
+      "add" /. handleAdd
+    , -- query flag
+      "add-if" /. handleAddIf
+    , -- capture
+      "mul" /. handleMul
+    , -- json body as input
+      "add-json" /. handleAddJson
+    , -- return error
+      "square-root" /. handleSquareRoot
+    ]
 
 data AddInput = AddInput
   { a :: Int

diff --git a/mig/src/Mig/Core/Class/Monad.hs b/mig/src/Mig/Core/Class/Monad.hs
@@ -13,3 +13,4 @@ type family MonadOf a :: (Type -> Type) where
   MonadOf (Request -> m (Maybe Response)) = m
   MonadOf (f m) = m
   MonadOf (a -> b) = MonadOf b
+  MonadOf [a] = MonadOf a
diff --git a/mig/src/Mig/Core/Class/Server.hs b/mig/src/Mig/Core/Class/Server.hs
@@ -62,6 +62,10 @@ class ToServer a where
 instance ToServer (Server m) where
   toServer = id
 
+-- list
+instance (ToServer a) => ToServer [a] where
+  toServer = foldMap toServer
+
 -- outputs
 instance (MonadIO m, IsResp a, IsMethod method) => ToServer (Send method m a) where
   toServer a = Server $ Api.HandleRoute (toRoute a)