From: Evgenii Akentev <i@ak3n.com>
Date: Sat, 9 Jan 2021 11:31:33 +0000 (+0500)
Subject: Improve vinyl-handle example with multiple providers.
X-Git-Url: https://git.ak3n.com/?a=commitdiff_plain;h=c5573550981adf22d4a0cabb009fd2e434b6069a;p=handle-examples.git

Improve vinyl-handle example with multiple providers.
---

diff --git a/README.md b/README.md
index 396d46e..053a18d 100644
--- a/README.md
+++ b/README.md
@@ -9,3 +9,5 @@ This repository contains examples of [the Handle pattern](https://jaspervdj.be/p
 - `backpack-handle` does the same thing as `records-handle` but using Backpack instead. It allows us to specialize function calls.
 
 - `backpack-handles` goes further and makes `WeatherProvider` and `WeatherReporter` signatures.
+
+- `vinyl-handle` explores the design space using `vinyl` instead of records as Handle. It supports the extension of the interfaces since `vinyl` allows to add fields to the records.
diff --git a/vinyl-handle/domain/QueryTypes.hs b/vinyl-handle/domain/QueryTypes.hs
new file mode 100644
index 0000000..91e2183
--- /dev/null
+++ b/vinyl-handle/domain/QueryTypes.hs
@@ -0,0 +1,4 @@
+module QueryTypes where
+
+type Location = String
+type Day = String
diff --git a/vinyl-handle/domain/TemperatureProvider.hs b/vinyl-handle/domain/TemperatureProvider.hs
new file mode 100644
index 0000000..8a2eec5
--- /dev/null
+++ b/vinyl-handle/domain/TemperatureProvider.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TemperatureProvider where
+
+import HandleRec
+import QueryTypes
+
+type Temperature = Int
+
+type Methods = '[ '("getTemperatureData", (Location -> Day -> IO Temperature)) ]
+
+type Handle = HandleRec Methods
diff --git a/vinyl-handle/domain/WeatherProvider.hs b/vinyl-handle/domain/WeatherProvider.hs
index b974fca..360861c 100644
--- a/vinyl-handle/domain/WeatherProvider.hs
+++ b/vinyl-handle/domain/WeatherProvider.hs
@@ -1,16 +1,20 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
 
 module WeatherProvider where
 
+import Data.Vinyl.TypeLevel
 import HandleRec
+import qualified WindProvider as W
+import qualified TemperatureProvider as T
+import QueryTypes
 
-type Temperature = Int
-data WeatherData = WeatherData { temperature :: Temperature }
+data WeatherData = WeatherData { temperature :: T.Temperature, wind :: W.WindSpeed }
 
-type Location = String
-type Day = String
+-- We union the methods of providers and extend it with a common method.
+type Methods = '[ '("getWeatherData", (Location -> Day -> IO WeatherData))
+  ] ++ W.Methods ++ T.Methods
+
+type Handle = HandleRec Methods
 
-type Handle = HandleRec
-  '[ '("getWeatherData", (Location -> Day -> IO WeatherData))
-  ]
diff --git a/vinyl-handle/domain/WeatherReporter.hs b/vinyl-handle/domain/WeatherReporter.hs
index 343cc91..31a0916 100644
--- a/vinyl-handle/domain/WeatherReporter.hs
+++ b/vinyl-handle/domain/WeatherReporter.hs
@@ -20,8 +20,9 @@ new = Handle
 
 -- | Domain logic. Usually some pure code that might use mtl, free monads, etc.
 createWeatherReport :: WeatherProvider.WeatherData -> WeatherReport
-createWeatherReport (WeatherProvider.WeatherData temp) =
+createWeatherReport (WeatherProvider.WeatherData temp wind) =
   "The current temperature in London is " ++ (show temp)
+  ++ " and wind speed is " ++ (show wind)
 
 -- | Domain logic that uses external dependency to get data and process it.
 getCurrentWeatherReportInLondon :: Handle -> IO WeatherReport
diff --git a/vinyl-handle/domain/WindProvider.hs b/vinyl-handle/domain/WindProvider.hs
new file mode 100644
index 0000000..bab1fb7
--- /dev/null
+++ b/vinyl-handle/domain/WindProvider.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module WindProvider where
+
+import HandleRec
+import QueryTypes
+
+type WindSpeed = Int
+
+type Methods = '[ '("getWindData", (Location -> Day -> IO WindSpeed)) ]
+
+type Handle = HandleRec Methods
+
diff --git a/vinyl-handle/impl/SuperWeatherProvider.hs b/vinyl-handle/impl/SuperWeatherProvider.hs
index b27871a..ea2b575 100644
--- a/vinyl-handle/impl/SuperWeatherProvider.hs
+++ b/vinyl-handle/impl/SuperWeatherProvider.hs
@@ -2,11 +2,22 @@ module SuperWeatherProvider where
 
 import Data.Vinyl
 import WeatherProvider
+import TemperatureProvider (Temperature)
+import WindProvider (WindSpeed)
+import QueryTypes
 
 new :: Handle
 new = Field getSuperWeatherData
+  :& Field getWindData
+  :& Field getTemperatureData
   :& RNil
 
 -- | This is some concrete implementation `WeatherProvider` interface
 getSuperWeatherData :: Location -> Day -> IO WeatherData
-getSuperWeatherData _ _ = return $ WeatherData 30
+getSuperWeatherData _ _ = return $ WeatherData 30 10
+
+getTemperatureData :: Location -> Day -> IO Temperature
+getTemperatureData _ _ = return 30
+
+getWindData :: Location -> Day -> IO WindSpeed
+getWindData _ _ = return 5
diff --git a/vinyl-handle/test-impl/TestWeatherProvider.hs b/vinyl-handle/test-impl/TestWeatherProvider.hs
index a31879e..f5ae089 100644
--- a/vinyl-handle/test-impl/TestWeatherProvider.hs
+++ b/vinyl-handle/test-impl/TestWeatherProvider.hs
@@ -2,16 +2,29 @@ module TestWeatherProvider where
 
 import Data.Vinyl
 import WeatherProvider
+import qualified TemperatureProvider as T
+import qualified WindProvider as W
+import QueryTypes
 
 -- | This is a configuration that allows to setup the provider for tests.
 data Config = Config
-  { initTemperature :: Temperature
+  { initTemperature :: T.Temperature
+  , initWindSpeed :: W.WindSpeed
   }
 
 new :: Config -> Handle
-new config = Field (getTestWeatherData $ initTemperature config)
+new config = Field (getTestWeatherData (initTemperature config) (initWindSpeed config))
+  :& Field (getWindData (initWindSpeed config))
+  :& Field (getTemperatureData (initTemperature config))
   :& RNil
 
 -- | This is an implementation `WeatherProvider` interface for tests
-getTestWeatherData :: Int -> Location -> Day -> IO WeatherData
-getTestWeatherData temp _ _ = return $ WeatherData temp
+-- We can configure it independently from other providers or reuse them.
+getTestWeatherData :: T.Temperature -> W.WindSpeed -> Location -> Day -> IO WeatherData
+getTestWeatherData temp wind _ _ = return $ WeatherData temp wind
+
+getTemperatureData :: T.Temperature -> Location -> Day -> IO T.Temperature
+getTemperatureData t _ _ = return t
+
+getWindData :: W.WindSpeed -> Location -> Day -> IO W.WindSpeed
+getWindData w _ _ = return w
diff --git a/vinyl-handle/test/Test.hs b/vinyl-handle/test/Test.hs
index 7466dd4..452ca21 100644
--- a/vinyl-handle/test/Test.hs
+++ b/vinyl-handle/test/Test.hs
@@ -2,23 +2,28 @@ import Test.Hspec
 
 import qualified TestWeatherProvider
 import qualified WeatherProvider
+import qualified TemperatureProvider
+import qualified WindProvider
 import qualified WeatherReporter
 
 main :: IO ()
 main = hspec spec
 
-weatherWithTemp :: WeatherProvider.Temperature -> WeatherReporter.Handle
-weatherWithTemp = WeatherReporter.new
-  . TestWeatherProvider.new
-  . TestWeatherProvider.Config
+weatherWithTempAndWind
+  :: TemperatureProvider.Temperature
+  -> WindProvider.WindSpeed
+  -> WeatherReporter.Handle
+weatherWithTempAndWind t w = WeatherReporter.new
+  $ TestWeatherProvider.new
+  $ TestWeatherProvider.Config t w
 
 spec :: Spec
 spec = describe "WeatherReporter" $ do
-  it "weather in London is 0" $ do
+  it "weather in London is 0 and wind is 5" $ do
     weatherReportInLondon <- WeatherReporter.getCurrentWeatherReportInLondon $
-      weatherWithTemp 0
-    weatherReportInLondon `shouldBe` "The current temperature in London is 0"
-  it "weather in London is -5" $ do
+      weatherWithTempAndWind 0 5
+    weatherReportInLondon `shouldBe` "The current temperature in London is 0 and wind speed is 5"
+  it "weather in London is -5 and wind is 10" $ do
     weatherReportInLondon <- WeatherReporter.getCurrentWeatherReportInLondon $
-      weatherWithTemp (-5)
-    weatherReportInLondon `shouldBe` "The current temperature in London is -5"
+      weatherWithTempAndWind (-5) 10
+    weatherReportInLondon `shouldBe` "The current temperature in London is -5 and wind speed is 10"
diff --git a/vinyl-handle/vinyl-handle.cabal b/vinyl-handle/vinyl-handle.cabal
index e007df9..c020c20 100644
--- a/vinyl-handle/vinyl-handle.cabal
+++ b/vinyl-handle/vinyl-handle.cabal
@@ -11,7 +11,10 @@ library domain
   hs-source-dirs: domain
   exposed-modules: WeatherProvider
                  , WeatherReporter
+                 , WindProvider
+                 , TemperatureProvider
                  , HandleRec
+                 , QueryTypes
   default-language: Haskell2010
   build-depends:    base, vinyl