From 13b140fffec62bfd0e2babc0ebe779c2ec2d3372 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Thu, 9 Sep 2021 00:06:35 +0500 Subject: [PATCH] Add row-handle --- row-handle/LICENSE | 21 +++++++++ row-handle/Main.hs | 19 ++++++++ row-handle/Setup.hs | 2 + row-handle/domain/HandleRow.hs | 17 +++++++ row-handle/domain/QueryTypes.hs | 4 ++ row-handle/domain/TemperatureProvider.hs | 19 ++++++++ row-handle/domain/WeatherProvider.hs | 25 ++++++++++ row-handle/domain/WeatherReporter.hs | 28 +++++++++++ row-handle/domain/WindProvider.hs | 19 ++++++++ row-handle/impl/SuperTemperatureProvider.hs | 12 +++++ row-handle/impl/SuperWeatherProvider.hs | 15 ++++++ row-handle/impl/SuperWindProvider.hs | 12 +++++ row-handle/row-handle.cabal | 51 +++++++++++++++++++++ row-handle/test-impl/TestWeatherProvider.hs | 30 ++++++++++++ row-handle/test/Test.hs | 29 ++++++++++++ 15 files changed, 303 insertions(+) create mode 100644 row-handle/LICENSE create mode 100644 row-handle/Main.hs create mode 100644 row-handle/Setup.hs create mode 100644 row-handle/domain/HandleRow.hs create mode 100644 row-handle/domain/QueryTypes.hs create mode 100644 row-handle/domain/TemperatureProvider.hs create mode 100644 row-handle/domain/WeatherProvider.hs create mode 100644 row-handle/domain/WeatherReporter.hs create mode 100644 row-handle/domain/WindProvider.hs create mode 100644 row-handle/impl/SuperTemperatureProvider.hs create mode 100644 row-handle/impl/SuperWeatherProvider.hs create mode 100644 row-handle/impl/SuperWindProvider.hs create mode 100644 row-handle/row-handle.cabal create mode 100644 row-handle/test-impl/TestWeatherProvider.hs create mode 100644 row-handle/test/Test.hs diff --git a/row-handle/LICENSE b/row-handle/LICENSE new file mode 100644 index 0000000..9eea539 --- /dev/null +++ b/row-handle/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Evgenii Akentev + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/row-handle/Main.hs b/row-handle/Main.hs new file mode 100644 index 0000000..5301f04 --- /dev/null +++ b/row-handle/Main.hs @@ -0,0 +1,19 @@ +module Main where + +import qualified SuperWeatherProvider +import qualified SuperWindProvider +import qualified SuperTemperatureProvider +import qualified WeatherProvider +import qualified WeatherReporter + +-- | This is an actual application where we use +-- our concrete implementation of `WeatherProvider`. +main :: IO () +main = do + let + wp = SuperWindProvider.new + tp = SuperTemperatureProvider.new + wph = SuperWeatherProvider.new wp tp + wrh = WeatherReporter.new wph + weatherReportInLondon <- WeatherReporter.getCurrentWeatherReportInLondon wrh + putStrLn weatherReportInLondon diff --git a/row-handle/Setup.hs b/row-handle/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/row-handle/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/row-handle/domain/HandleRow.hs b/row-handle/domain/HandleRow.hs new file mode 100644 index 0000000..74000fd --- /dev/null +++ b/row-handle/domain/HandleRow.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeOperators #-} + +module HandleRow where + +import Data.Row + +type HandleRow rs = Rec rs + +getMethod :: forall l r . KnownSymbol l => Rec r -> r .! l +getMethod = flip (.!) (Label @l) diff --git a/row-handle/domain/QueryTypes.hs b/row-handle/domain/QueryTypes.hs new file mode 100644 index 0000000..91e2183 --- /dev/null +++ b/row-handle/domain/QueryTypes.hs @@ -0,0 +1,4 @@ +module QueryTypes where + +type Location = String +type Day = String diff --git a/row-handle/domain/TemperatureProvider.hs b/row-handle/domain/TemperatureProvider.hs new file mode 100644 index 0000000..735c204 --- /dev/null +++ b/row-handle/domain/TemperatureProvider.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module TemperatureProvider where + +import Data.Row +import HandleRow +import QueryTypes + +type Temperature = Int + +type Methods = "getTemperatureData" .== (Location -> Day -> IO Temperature) + +type Handle = HandleRow Methods + +getTemperatureData :: Handle -> Location -> Day -> IO Temperature +getTemperatureData = getMethod @"getTemperatureData" diff --git a/row-handle/domain/WeatherProvider.hs b/row-handle/domain/WeatherProvider.hs new file mode 100644 index 0000000..0a89ce9 --- /dev/null +++ b/row-handle/domain/WeatherProvider.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} + +module WeatherProvider where + +import Data.Row +import HandleRow +import qualified WindProvider as W +import qualified TemperatureProvider as T +import QueryTypes + +data WeatherData = WeatherData { temperature :: T.Temperature, wind :: W.WindSpeed } + +-- 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 = HandleRow Methods + +getWeatherData :: Handle -> Location -> Day -> IO WeatherData +getWeatherData = getMethod @"getWeatherData" + +getWindData :: Handle -> Location -> Day -> IO W.WindSpeed +getWindData = getMethod @"getWindData" diff --git a/row-handle/domain/WeatherReporter.hs b/row-handle/domain/WeatherReporter.hs new file mode 100644 index 0000000..b5aec33 --- /dev/null +++ b/row-handle/domain/WeatherReporter.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +module WeatherReporter where + +import qualified WeatherProvider + +type WeatherReport = String + +-- | We hide dependencies in the handle +data Handle = Handle { weatherProvider :: WeatherProvider.Handle } + +-- | Constructor for Handle +new :: WeatherProvider.Handle -> Handle +new = Handle + +-- | Domain logic. Usually some pure code that might use mtl, free monads, etc. +createWeatherReport :: WeatherProvider.WeatherData -> WeatherReport +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 +getCurrentWeatherReportInLondon (Handle wph) = do + weatherData <- WeatherProvider.getWeatherData wph "London" "now" + return $ createWeatherReport weatherData diff --git a/row-handle/domain/WindProvider.hs b/row-handle/domain/WindProvider.hs new file mode 100644 index 0000000..333780a --- /dev/null +++ b/row-handle/domain/WindProvider.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module WindProvider where + +import Data.Row +import HandleRow +import QueryTypes + +type WindSpeed = Int + +type Methods = "getWindData" .== (Location -> Day -> IO WindSpeed) + +type Handle = HandleRow Methods + +getWindData :: Handle -> Location -> Day -> IO WindSpeed +getWindData = getMethod @"getWindData" diff --git a/row-handle/impl/SuperTemperatureProvider.hs b/row-handle/impl/SuperTemperatureProvider.hs new file mode 100644 index 0000000..ab58660 --- /dev/null +++ b/row-handle/impl/SuperTemperatureProvider.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedLabels #-} +module SuperTemperatureProvider where + +import Data.Row +import TemperatureProvider +import QueryTypes + +new :: Handle +new = #getTemperatureData .== getSuperTemperatureData + +getSuperTemperatureData :: Location -> Day -> IO Temperature +getSuperTemperatureData _ _ = return 30 diff --git a/row-handle/impl/SuperWeatherProvider.hs b/row-handle/impl/SuperWeatherProvider.hs new file mode 100644 index 0000000..3a110f2 --- /dev/null +++ b/row-handle/impl/SuperWeatherProvider.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedLabels #-} +module SuperWeatherProvider where + +import Data.Row +import WeatherProvider +import qualified TemperatureProvider +import qualified WindProvider +import QueryTypes + +new :: WindProvider.Handle -> TemperatureProvider.Handle -> Handle +new wp tp = #getWeatherData .== getSuperWeatherData .+ wp .+ tp + +-- | This is some concrete implementation `WeatherProvider` interface +getSuperWeatherData :: Location -> Day -> IO WeatherData +getSuperWeatherData _ _ = return $ WeatherData 30 10 diff --git a/row-handle/impl/SuperWindProvider.hs b/row-handle/impl/SuperWindProvider.hs new file mode 100644 index 0000000..8139cfb --- /dev/null +++ b/row-handle/impl/SuperWindProvider.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedLabels #-} +module SuperWindProvider where + +import Data.Row +import WindProvider +import QueryTypes + +new :: Handle +new = #getWindData .== getSuperWindData + +getSuperWindData :: Location -> Day -> IO WindSpeed +getSuperWindData _ _ = return 5 diff --git a/row-handle/row-handle.cabal b/row-handle/row-handle.cabal new file mode 100644 index 0000000..fec968e --- /dev/null +++ b/row-handle/row-handle.cabal @@ -0,0 +1,51 @@ +cabal-version: >=2.0 +name: row-handle +version: 0.1.0.0 +license-file: LICENSE +author: Evgenii Akentev +maintainer: i@ak3n.com +build-type: Simple +extra-source-files: CHANGELOG.md + +library domain + hs-source-dirs: domain + exposed-modules: WeatherProvider + , WeatherReporter + , WindProvider + , TemperatureProvider + , HandleRow + , QueryTypes + default-language: Haskell2010 + build-depends: base, row-types + +library impl + hs-source-dirs: impl + exposed-modules: SuperWeatherProvider + , SuperWindProvider + , SuperTemperatureProvider + default-language: Haskell2010 + build-depends: base, domain, row-types + +library test-impl + hs-source-dirs: test-impl + exposed-modules: TestWeatherProvider + default-language: Haskell2010 + build-depends: base, domain, row-types + +executable main + main-is: Main.hs + build-depends: base >=4.13 && <5 + , domain + , impl + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , QuickCheck + , hspec + , domain + , test-impl diff --git a/row-handle/test-impl/TestWeatherProvider.hs b/row-handle/test-impl/TestWeatherProvider.hs new file mode 100644 index 0000000..37cc911 --- /dev/null +++ b/row-handle/test-impl/TestWeatherProvider.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedLabels #-} +module TestWeatherProvider where + +import Data.Row +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 :: T.Temperature + , initWindSpeed :: W.WindSpeed + } + +new :: Config -> Handle +new config = #getWeatherData .== (getTestWeatherData (initTemperature config) (initWindSpeed config)) + .+ #getWindData .== (getTestWindData (initWindSpeed config)) + .+ #getTemperatureData .== (getTestTemperatureData (initTemperature config)) + +-- | This is an implementation `WeatherProvider` interface for tests +-- 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 + +getTestTemperatureData :: T.Temperature -> Location -> Day -> IO T.Temperature +getTestTemperatureData t _ _ = return t + +getTestWindData :: W.WindSpeed -> Location -> Day -> IO W.WindSpeed +getTestWindData w _ _ = return w diff --git a/row-handle/test/Test.hs b/row-handle/test/Test.hs new file mode 100644 index 0000000..452ca21 --- /dev/null +++ b/row-handle/test/Test.hs @@ -0,0 +1,29 @@ +import Test.Hspec + +import qualified TestWeatherProvider +import qualified WeatherProvider +import qualified TemperatureProvider +import qualified WindProvider +import qualified WeatherReporter + +main :: IO () +main = hspec spec + +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 and wind is 5" $ do + weatherReportInLondon <- WeatherReporter.getCurrentWeatherReportInLondon $ + 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 $ + weatherWithTempAndWind (-5) 10 + weatherReportInLondon `shouldBe` "The current temperature in London is -5 and wind speed is 10" -- 2.34.1