From 424930589312bd3546fdcdc2f2fa62a7424bab33 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 31 Mar 2021 09:53:14 -0500 Subject: [PATCH 01/11] Add free --- core-s4n/core-s4n.cabal | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/core-s4n/core-s4n.cabal b/core-s4n/core-s4n.cabal index c1e65f0..c1fc48f 100644 --- a/core-s4n/core-s4n.cabal +++ b/core-s4n/core-s4n.cabal @@ -19,12 +19,17 @@ extra-source-files: CHANGELOG.md library exposed-modules: Core.Dsl + Core.Fsl + Core.Drone + Core.Interpreter + Core.Service other-modules: Paths_core_s4n hs-source-dirs: src build-depends: - base >= 4.7 && < 5 + base >= 4.7 && < 5 + , free , lens >=4.0 && <4.20 default-language: Haskell2010 @@ -42,6 +47,7 @@ test-suite core-s4n-test , base >=4.5 && <5 , bytestring >=0.10.10 && <0.11 , exceptions + , free , hspec , lens >=4.0 && <4.20 , text From 2e806d32f5811df2abe545fd02e283bfc6e876e6 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Mon, 12 Apr 2021 10:11:50 -0500 Subject: [PATCH 02/11] Add Drone --- core-s4n/src/Core/Drone.hs | 76 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 core-s4n/src/Core/Drone.hs diff --git a/core-s4n/src/Core/Drone.hs b/core-s4n/src/Core/Drone.hs new file mode 100644 index 0000000..98c7706 --- /dev/null +++ b/core-s4n/src/Core/Drone.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Core.Drone + ( Drone, + drone, + origin, + Position (..), + Direction (..), + Coordinates, + north, + south, + east, + west, + cx, + cy, + x, + y, + ) +where + +import Control.Lens + ( makeLenses, + makePrisms, + ) +import Data.Maybe (fromJust) + +data Direction = North | South | East | West deriving (Show) + +north :: Direction +north = North + +south :: Direction +south = South + +east :: Direction +east = East + +west :: Direction +west = West + +newtype X = X {_x :: Int} + +makeLenses ''X + +instance Show X where + show (X x) = show x + +newtype Y = Y {_y :: Int} + +makeLenses ''Y + +instance Show Y where + show (Y y) = show y + +data Coordinates = Coordinates {_cx :: X, _cy :: Y} + +makeLenses ''Coordinates + +instance Show Coordinates where + show (Coordinates x y) = + "(" <> show x <> ", " <> show y <> ")" + +data Position = Position {_coord :: Coordinates, _dir :: Direction} + +makeLenses ''Position + +instance Show Position where + show (Position c d) = show c <> " " <> show d + +origin :: Position +origin = Position (Coordinates (X 0) (Y 0)) North + +data Drone = Drone String [Position] deriving (Show) + +drone :: String -> [Position] -> Drone +drone = Drone From 42ef318972fc931d0342d7debe5daa436ba19be0 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Mon, 12 Apr 2021 10:13:21 -0500 Subject: [PATCH 03/11] Add Fsl and Interpreter --- core-s4n/src/Core/Fsl.hs | 61 +++++++++++++++++++++++++++++++ core-s4n/src/Core/Interpreter.hs | 63 ++++++++++++++++++++++++++++++++ 2 files changed, 124 insertions(+) create mode 100644 core-s4n/src/Core/Fsl.hs create mode 100644 core-s4n/src/Core/Interpreter.hs diff --git a/core-s4n/src/Core/Fsl.hs b/core-s4n/src/Core/Fsl.hs new file mode 100644 index 0000000..3167c6b --- /dev/null +++ b/core-s4n/src/Core/Fsl.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Core.Fsl + ( Cmd (..), + Fsl, + makeFsl, + a, + i, + d, + ) +where + +import Control.Lens (makePrisms) +import Control.Monad.Free (Free (..)) + +data Cmd a + = A a + | I a + | D a + +makePrisms ''Cmd + +instance Show a => Show (Cmd a) where + show (A cmd) = "A(" <> show cmd <> ")" + show (I cmd) = "I(" <> show cmd <> ")" + show (D cmd) = "D(" <> show cmd <> ")" + +instance Functor Cmd where + fmap f (A a) = A (f a) + fmap f (I a) = I (f a) + fmap f (D a) = D (f a) + +type Fsl a = Free Cmd a + +end :: Fsl () +end = Pure () + +a :: Fsl () -> Fsl () +a next = Free (A next) + +i :: Fsl () -> Fsl () +i next = Free (I next) + +d :: Fsl () -> Fsl () +d next = Free (D next) + +makeFsl :: String -> Either String (Fsl ()) +makeFsl [] = Right (Pure ()) +makeFsl cmd = + makeFslR (reverse cmd) end + where + reverse :: [Char] -> String + reverse xs = foldl (flip (:)) [] xs + makeFslR :: String -> Fsl () -> Either String (Fsl ()) + makeFslR [] next = Right next + makeFslR (h : t) next = + case h of + 'A' -> makeFslR t (a next) + 'I' -> makeFslR t (i next) + 'D' -> makeFslR t (d next) + _ -> Left "Invalid Char Input" diff --git a/core-s4n/src/Core/Interpreter.hs b/core-s4n/src/Core/Interpreter.hs new file mode 100644 index 0000000..c22e3b9 --- /dev/null +++ b/core-s4n/src/Core/Interpreter.hs @@ -0,0 +1,63 @@ +module Core.Interpreter (eval) where + +import Control.Lens + ( Field1 (_1), + (%~), + (&), + (?~), + ) +import Control.Monad.Free (Free (..)) +import Core.Drone + ( Coordinates, + Direction (East, North, South, West), + Position (Position), + cx, + cy, + east, + north, + origin, + south, + west, + x, + y, + ) +import qualified Core.Dsl as Dsl +import qualified Core.Fsl as Fsl + +eval :: Fsl.Fsl () -> Position +eval = cslInterpreter origin + +cslInterpreter :: Position -> Fsl.Fsl () -> Position +cslInterpreter previous (Pure _) = previous +cslInterpreter previous (Free next@(Fsl.A csl)) = + cslInterpreter (cmdInterpreter previous next) csl +cslInterpreter previous (Free next@(Fsl.I csl)) = + cslInterpreter (cmdInterpreter previous next) csl +cslInterpreter previous (Free next@(Fsl.D csl)) = + cslInterpreter (cmdInterpreter previous next) csl + +cmdInterpreter :: Position -> Fsl.Cmd (Fsl.Fsl ()) -> Position +cmdInterpreter (Position c North) cmd = fromNorth cmd c +cmdInterpreter (Position c South) cmd = fromSouth cmd c +cmdInterpreter (Position c West) cmd = fromWest cmd c +cmdInterpreter (Position c East) cmd = fromEast cmd c + +fromNorth :: Fsl.Cmd (Fsl.Fsl ()) -> Coordinates -> Position +fromNorth (Fsl.A csl) c = Position (c & (cy . y) %~ (+ 1)) north +fromNorth (Fsl.I csl) c = Position c east +fromNorth (Fsl.D csl) c = Position c west + +fromSouth :: Fsl.Cmd (Fsl.Fsl ()) -> Coordinates -> Position +fromSouth (Fsl.A csl) c = Position (c & (cy . y) %~ (+ (-1))) south +fromSouth (Fsl.I csl) c = Position c west +fromSouth (Fsl.D csl) c = Position c east + +fromWest :: Fsl.Cmd (Fsl.Fsl ()) -> Coordinates -> Position +fromWest (Fsl.A csl) c = Position (c & (cx . x) %~ (+ 1)) west +fromWest (Fsl.I csl) c = Position c north +fromWest (Fsl.D csl) c = Position c south + +fromEast :: Fsl.Cmd (Fsl.Fsl ()) -> Coordinates -> Position +fromEast (Fsl.A csl) c = Position (c & (cx . x) %~ (+ (-1))) east +fromEast (Fsl.I csl) c = Position c south +fromEast (Fsl.D csl) c = Position c north From 3c931c7227f6ae1ad9b7bfb4db5a0d35596e9a19 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Mon, 12 Apr 2021 10:13:36 -0500 Subject: [PATCH 04/11] Add Core Service --- core-s4n/src/Core/Service.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 core-s4n/src/Core/Service.hs diff --git a/core-s4n/src/Core/Service.hs b/core-s4n/src/Core/Service.hs new file mode 100644 index 0000000..5345eb1 --- /dev/null +++ b/core-s4n/src/Core/Service.hs @@ -0,0 +1,13 @@ +module Core.Service where + +import Core.Drone (Drone, Position, drone) +import Core.Fsl (Fsl) +import Core.Interpreter (eval) + +data CoreHandle = CoreHandle + { mkPosition :: Fsl () -> Position, + mkDrone :: String -> [Position] -> Drone + } + +defaultCoreHandle :: CoreHandle +defaultCoreHandle = CoreHandle eval drone From 02534255aeb7675290fd291e3e5e4f63a4ee9b8f Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:26:34 -0500 Subject: [PATCH 05/11] Add free --- infrastructure/logs/logs.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/infrastructure/logs/logs.cabal b/infrastructure/logs/logs.cabal index 1c05806..7dbcdeb 100644 --- a/infrastructure/logs/logs.cabal +++ b/infrastructure/logs/logs.cabal @@ -20,6 +20,8 @@ library exposed-modules: Logs.Config.LogConfig Logs.Log + Logs.Dsl + Logs.Interpreter other-modules: Paths_logs hs-source-dirs: @@ -27,6 +29,7 @@ library build-depends: base >= 4.7 && < 5 , directory + , free , katip >= 0.1.0.0 && < 0.8.6.0 , envs default-language: Haskell2010 From 9018c28f29cf472733d536a5a15cdee69d132397 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:26:55 -0500 Subject: [PATCH 06/11] Files dsl --- infrastructure/files/src/Files/Dsl.hs | 98 +++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 infrastructure/files/src/Files/Dsl.hs diff --git a/infrastructure/files/src/Files/Dsl.hs b/infrastructure/files/src/Files/Dsl.hs new file mode 100644 index 0000000..dec0671 --- /dev/null +++ b/infrastructure/files/src/Files/Dsl.hs @@ -0,0 +1,98 @@ +module Files.Dsl + ( ResourceF (..), + ResourceScript, + Directory (..), + Extension (..), + Filename (..), + File (..), + Line (..), + create, + get, + put, + mkAll, + mkCustom, + mkDirectory, + mkFile, + mkFilename, + mkLine, + ) +where + +import Control.Monad.Free (Free (..)) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack, unpack) +import Data.Char (toUpper) +import Logs.Dsl (LoggerScript) +import System.Directory + ( createDirectoryIfMissing, + doesDirectoryExist, + listDirectory, + removeDirectoryRecursive, + ) +import System.FilePath (takeBaseName, takeExtension, ()) +import System.IO + ( FilePath, + readFile, + writeFile, + ) + +newtype Directory = Directory String deriving (Show) + +mkDirectory :: String -> Directory +mkDirectory = Directory + +newtype Line = Line {line :: String} deriving (Show) + +mkLine :: String -> Line +mkLine = Line + +instance Semigroup Line where + (Line x) <> (Line "") = Line x + (Line "") <> (Line y) = Line y + (Line x) <> (Line y) = Line (x <> "\n" <> y) + +data Extension + = All + | Custom String + deriving (Show, Eq) + +mkAll :: Extension +mkAll = All + +mkCustom :: String -> Extension +mkCustom = Custom + +newtype Filename = Filename String deriving (Show) + +mkFilename :: String -> Filename +mkFilename = Filename + +data File = File Filename [Line] deriving (Show) + +mkFile :: Filename -> [Line] -> File +mkFile = File + +data ResourceF a + = Get (LoggerScript ()) Directory Extension ([File] -> a) + | Put (LoggerScript ()) File Directory a + | Create (LoggerScript ()) Directory (FilePath -> a) + +instance Functor ResourceF where + fmap f (Get log dir ext g) = Get log dir ext (f . g) + fmap f (Put log file dir a) = Put log file dir (f a) + fmap f (Create log dir g) = Create log dir (f . g) + +type ResourceScript a = Free ResourceF a + +get :: + LoggerScript () -> + Directory -> + Extension -> + ResourceScript [File] +get log dir ext = Free $ Get log dir ext pure + +put :: LoggerScript () -> File -> Directory -> ResourceScript () +put log file dir = Free $ Put log file dir (pure ()) + +create :: LoggerScript () -> Directory -> ResourceScript FilePath +create log dir = Free $ Create log dir pure From 80e04f1f00971ce1cc8b0c51a99d0e8803e76dc5 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:27:16 -0500 Subject: [PATCH 07/11] Add files interpreter --- infrastructure/files/src/Files/Interpreter.hs | 93 +++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 infrastructure/files/src/Files/Interpreter.hs diff --git a/infrastructure/files/src/Files/Interpreter.hs b/infrastructure/files/src/Files/Interpreter.hs new file mode 100644 index 0000000..d00ba67 --- /dev/null +++ b/infrastructure/files/src/Files/Interpreter.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TupleSections #-} + +module Files.Interpreter (resourceInterpret, ResourceInterpreter (..)) where + +import Control.Monad.Free (Free (..)) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack, unpack) +import Data.Char (toUpper) +import Files.Dsl + ( Directory (..), + Extension (..), + File (..), + Filename (..), + Line (..), + ResourceF (..), + ResourceScript, + ) +import Logs.Interpreter (LoggerInterpreter (..), loggerInterpret) +import System.Directory + ( createDirectoryIfMissing, + doesDirectoryExist, + listDirectory, + removeDirectoryRecursive, + ) +import System.FilePath (takeBaseName, takeExtension, ()) +import System.IO + ( FilePath, + readFile, + writeFile, + ) + +class Monad m => ResourceInterpreter m where + onGet :: Directory -> Extension -> m [File] + onPut :: File -> Directory -> m () + onCreate :: Directory -> m FilePath + +resourceInterpret :: + ( Monad m, + ResourceInterpreter m, + LoggerInterpreter m + ) => + ResourceScript a -> + m a +resourceInterpret (Pure a) = return a +resourceInterpret (Free (Get l dir ext next)) = do + _ <- loggerInterpret l + v <- onGet dir ext + resourceInterpret (next v) +resourceInterpret (Free (Put l file dir v)) = do + _ <- loggerInterpret l + onPut file dir + resourceInterpret v +resourceInterpret (Free (Create l dir next)) = do + _ <- loggerInterpret l + v <- onCreate dir + resourceInterpret (next v) + +instance ResourceInterpreter IO where + onGet (Directory dir') ext = do + f <- listDirectory dir' + let fp = (dir' ) <$> clean f ext + files <- readF fp + return $ tupleToFile <$> files + where + clean :: [FilePath] -> Extension -> [FilePath] + clean fp' All = fp' + clean fp' (Custom ext) = filter (\a -> takeExtension a == ext) fp' + readF :: [FilePath] -> IO [(FilePath, String)] + readF [] = pure [] + readF fp = sequence $ (\fp' -> (fp',) <$> readFile fp') <$> fp + tupleToFile :: (FilePath, String) -> File + tupleToFile (fp, s) = + File (Filename $ takeBaseName fp) (Line <$> lines s) + onPut (File (Filename name') lines') (Directory dir') = do + let filename = dir' name' + writeFile filename (readLines lines') + where + readLines :: [Line] -> String + readLines [] = "" + readLines lines = line $ getLine lines + getLine :: [Line] -> Line + getLine lines = foldl (<>) (Line "") lines + onCreate (Directory dir') = do + _ <- remove dir' + _ <- createDirectoryIfMissing True dir' + pure dir' + where + remove :: FilePath -> IO () + remove dir = do + exists <- doesDirectoryExist dir + if exists + then removeDirectoryRecursive dir + else pure () From 4c2418d9e6a782df3858fc2025cfcc18af969fb1 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:29:05 -0500 Subject: [PATCH 08/11] Add logs dsl --- infrastructure/logs/src/Logs/Dsl.hs | 54 +++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 infrastructure/logs/src/Logs/Dsl.hs diff --git a/infrastructure/logs/src/Logs/Dsl.hs b/infrastructure/logs/src/Logs/Dsl.hs new file mode 100644 index 0000000..0651144 --- /dev/null +++ b/infrastructure/logs/src/Logs/Dsl.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GADTs #-} + +module Logs.Dsl + ( LoggerF (..), + LoggerScript, + LogLevel (..), + LogCtx (..), + LogMsg (..), + mkInfo, + mkError, + mkDebug, + mkWarning, + mkLogCtx, + mkLogMsg, + logger, + ) +where + +import Control.Monad.Free (Free (..), liftF) + +data LogLevel = Info | Error | Debug | Warning + +mkInfo :: LogLevel +mkInfo = Info + +mkError :: LogLevel +mkError = Error + +mkDebug :: LogLevel +mkDebug = Debug + +mkWarning :: LogLevel +mkWarning = Warning + +newtype LogCtx = LogCtx String + +mkLogCtx :: String -> LogCtx +mkLogCtx = LogCtx + +newtype LogMsg = LogMsg String + +mkLogMsg :: String -> LogMsg +mkLogMsg = LogMsg + +data LoggerF a where + Log :: LogLevel -> LogCtx -> LogMsg -> a -> LoggerF a + +instance Functor LoggerF where + fmap f (Log level ctx msg a) = Log level ctx msg (f a) + +type LoggerScript a = Free LoggerF a + +logger :: LogLevel -> LogCtx -> LogMsg -> LoggerScript () +logger level ctx msg = Free $ Log level ctx msg (pure ()) From f6943d4b563827ce6b31084bab413297e07df1de Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:29:23 -0500 Subject: [PATCH 09/11] Add logs interpreter --- infrastructure/logs/src/Logs/Interpreter.hs | 73 +++++++++++++++++++++ 1 file changed, 73 insertions(+) create mode 100644 infrastructure/logs/src/Logs/Interpreter.hs diff --git a/infrastructure/logs/src/Logs/Interpreter.hs b/infrastructure/logs/src/Logs/Interpreter.hs new file mode 100644 index 0000000..6e70341 --- /dev/null +++ b/infrastructure/logs/src/Logs/Interpreter.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Logs.Interpreter (loggerInterpret, LoggerInterpreter (..)) where + +import Control.Exception (bracket) +import Control.Monad.Free (Free (..)) +import Data.Maybe (fromMaybe) +import Data.Semigroup ((<>)) +import Data.String (fromString) +import Katip + ( ColorStrategy (ColorIfTerminal), + LogEnv, + Severity (DebugS, ErrorS, InfoS, WarningS), + Verbosity (V2), + closeScribes, + defaultScribeSettings, + initLogEnv, + logStr, + logTM, + mkFileScribe, + mkHandleScribe, + permitItem, + registerScribe, + runKatipContextT, + ) +import Logs.Config.LogConfig (FromEnv (..), LogConfig (..)) +import Logs.Dsl + ( LogCtx (..), + LogLevel (..), + LogMsg (..), + LoggerF (..), + LoggerScript, + ) +import System.Directory (createDirectoryIfMissing) +import System.Environment (lookupEnv) +import System.IO (stdout) + +class Monad m => LoggerInterpreter m where + onLog :: LogLevel -> LogCtx -> LogMsg -> m () + +loggerInterpret :: (Monad m, LoggerInterpreter m) => LoggerScript a -> m a +loggerInterpret (Pure a) = return a +loggerInterpret (Free (Log level ctx msg v)) = do + onLog level ctx msg + loggerInterpret v + +instance LoggerInterpreter IO where + onLog level (LogCtx ctx) (LogMsg msg) = do + envs <- fromEnv + bracket (makeLogEnv envs) closeScribes (\env -> logAction env level ctx msg) + where + makeLogEnv :: LogConfig -> IO LogEnv + makeLogEnv (LogConfig dir' filename' name env) = do + let file = dir' <> "/" <> filename' + logEnv <- + initLogEnv + (fromString name) + (fromString env) + _ <- createDirectoryIfMissing True dir' + stdoutScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2 + fileScribe <- mkFileScribe file (permitItem InfoS) V2 + newLogEnv <- registerScribe "stdout" stdoutScribe defaultScribeSettings logEnv + registerScribe "file" fileScribe defaultScribeSettings newLogEnv + logAction :: LogEnv -> LogLevel -> String -> String -> IO () + logAction env level ctx msg = + runKatipContextT env () "" $ do + $(logTM) (katipLevel level) $ logStr msg + katipLevel :: LogLevel -> Severity + katipLevel Info = InfoS + katipLevel Error = ErrorS + katipLevel Warning = WarningS + katipLevel Debug = DebugS From b9ee860f5ebad77e7390654dcc3d61788748e650 Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 14 Apr 2021 16:29:41 -0500 Subject: [PATCH 10/11] Add free --- infrastructure/files/files.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/infrastructure/files/files.cabal b/infrastructure/files/files.cabal index ce0010f..6604cd8 100644 --- a/infrastructure/files/files.cabal +++ b/infrastructure/files/files.cabal @@ -19,6 +19,8 @@ extra-source-files: CHANGELOG.md library exposed-modules: Files.File + Files.Dsl + Files.Interpreter other-modules: Paths_files hs-source-dirs: @@ -33,6 +35,7 @@ library , conduit-extra , directory , filepath + , free , katip >= 0.1.0.0 && < 0.8.6.0 , resourcet , text From 3c834cbf05d516e4908887fb826492413e6d147e Mon Sep 17 00:00:00 2001 From: Will Leyton Date: Wed, 28 Apr 2021 12:36:34 -0500 Subject: [PATCH 11/11] Update --- app/Main.hs | 20 +++- .../delivery-adapter/delivery-adapter.cabal | 2 + .../src/Delivery/Adapter/Interpreter.hs | 29 ++++++ .../delivery-application.cabal | 3 +- .../delivery-domain/delivery-domain.cabal | 5 + .../Delivery/Domain/Configuration/Config.hs | 15 +++ .../src/Delivery/Domain/Dsl.hs | 36 ++++++++ .../location-adapter/location-adapter.cabal | 2 + .../src/Location/Adapter/Interpreter.hs | 29 ++++++ .../location-application.cabal | 5 +- .../src/Location/Application/Dsl.hs | 27 ++++++ .../location-domain/location-domain.cabal | 5 + .../Location/Domain/Configuration/Config.hs | 14 +++ .../src/Location/Domain/Dsl.hs | 32 +++++++ package.yaml | 2 + prueba-s4n-haskell.cabal | 10 +- src/AppF.hs | 92 +++++++++++++++++++ src/Env.hs | 11 +++ 18 files changed, 335 insertions(+), 4 deletions(-) create mode 100644 delivery/delivery-adapter/src/Delivery/Adapter/Interpreter.hs create mode 100644 delivery/delivery-domain/src/Delivery/Domain/Configuration/Config.hs create mode 100644 delivery/delivery-domain/src/Delivery/Domain/Dsl.hs create mode 100644 location/location-adapter/src/Location/Adapter/Interpreter.hs create mode 100644 location/location-application/src/Location/Application/Dsl.hs create mode 100644 location/location-domain/src/Location/Domain/Configuration/Config.hs create mode 100644 location/location-domain/src/Location/Domain/Dsl.hs create mode 100644 src/AppF.hs create mode 100644 src/Env.hs diff --git a/app/Main.hs b/app/Main.hs index 0e83b53..e36148e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,24 @@ module Main where import App (app) +import qualified AppF as F +import qualified Delivery.Domain.Configuration.Config as DC +import qualified Delivery.Domain.Dsl as Dsl +import Files.Dsl (mkCustom, mkDirectory) main :: IO () -main = app +main = do + --_ <- F.runApp F.evalLogger "" + let input = mkDirectory "/Users/will/Desktop/in" + ext = mkCustom ".txt" + output = mkDirectory "/Users/will/Desktop/out2" + config' = DC.config "/Users/will/Desktop/in" "in" ".txt" 2 + --f <- F.runApp $ F.getFiles "GetFiles" input ext + --_ <- F.runApp $ F.createDirectory "CreateDir" output + --let saved = (\f -> F.runApp (F.writeFile "WriteFile" f output)) <$> f + --sequence_ saved + --print f + drones <- F.runApp $ F.basicProgram "BasicProgram" config' + print drones + +--main = app diff --git a/delivery/delivery-adapter/delivery-adapter.cabal b/delivery/delivery-adapter/delivery-adapter.cabal index e2cb9e8..fdbb953 100644 --- a/delivery/delivery-adapter/delivery-adapter.cabal +++ b/delivery/delivery-adapter/delivery-adapter.cabal @@ -21,6 +21,7 @@ library exposed-modules: Delivery.Adapter.Config.DeliveryConfig Delivery.Adapter.Repository + Delivery.Adapter.Interpreter other-modules: Paths_delivery_adapter hs-source-dirs: @@ -30,6 +31,7 @@ library , base >= 4.7 && < 5 , katip >= 0.1.0.0 && < 0.8.6.0 , MissingH + , free , envs , logs , files diff --git a/delivery/delivery-adapter/src/Delivery/Adapter/Interpreter.hs b/delivery/delivery-adapter/src/Delivery/Adapter/Interpreter.hs new file mode 100644 index 0000000..ee6eca4 --- /dev/null +++ b/delivery/delivery-adapter/src/Delivery/Adapter/Interpreter.hs @@ -0,0 +1,29 @@ +module Delivery.Adapter.Interpreter (DeliveryInterpreter (..), deliveryInterpret) where + +import Control.Monad.Free (Free (..)) +import Core.Drone (Drone) +import Delivery.Domain.Dsl (DeliveryF (..), DeliveryScript) +import Files.Dsl (File) +import Files.Interpreter (ResourceInterpreter, resourceInterpret) +import Logs.Interpreter (LoggerInterpreter, loggerInterpret) + +class Monad m => DeliveryInterpreter m where + onGet :: [File] -> ([File] -> [Drone]) -> m [Drone] + +instance DeliveryInterpreter IO where + onGet files' f = return $ f files' + +deliveryInterpret :: + ( Monad m, + ResourceInterpreter m, + LoggerInterpreter m, + DeliveryInterpreter m + ) => + DeliveryScript a -> + m a +deliveryInterpret (Pure a) = return a +deliveryInterpret (Free (Get l r f next)) = do + _ <- loggerInterpret l + files' <- resourceInterpret r + v <- onGet files' f + deliveryInterpret (next v) diff --git a/delivery/delivery-application/delivery-application.cabal b/delivery/delivery-application/delivery-application.cabal index 114263e..7f59d32 100644 --- a/delivery/delivery-application/delivery-application.cabal +++ b/delivery/delivery-application/delivery-application.cabal @@ -26,8 +26,9 @@ library src build-depends: base >= 4.7 && < 5 - , logs + , free , core-s4n + , logs , delivery-domain , location-application default-language: Haskell2010 diff --git a/delivery/delivery-domain/delivery-domain.cabal b/delivery/delivery-domain/delivery-domain.cabal index a7cbbac..03249fa 100644 --- a/delivery/delivery-domain/delivery-domain.cabal +++ b/delivery/delivery-domain/delivery-domain.cabal @@ -20,11 +20,16 @@ extra-source-files: CHANGELOG.md library exposed-modules: Delivery.Domain.Repository + Delivery.Domain.Dsl + Delivery.Domain.Configuration.Config other-modules: Paths_delivery_domain hs-source-dirs: src build-depends: base >= 4.7 && < 5 + , free , core-s4n + , logs + , files default-language: Haskell2010 diff --git a/delivery/delivery-domain/src/Delivery/Domain/Configuration/Config.hs b/delivery/delivery-domain/src/Delivery/Domain/Configuration/Config.hs new file mode 100644 index 0000000..6a247a4 --- /dev/null +++ b/delivery/delivery-domain/src/Delivery/Domain/Configuration/Config.hs @@ -0,0 +1,15 @@ +module Delivery.Domain.Configuration.Config + ( DeliveryConfig (..), + config, + ) +where + +data DeliveryConfig = DeliveryConfig + { inPath :: String, + prefix :: String, + extension :: String, + prefixLength :: Int + } + +config :: String -> String -> String -> Int -> DeliveryConfig +config = DeliveryConfig diff --git a/delivery/delivery-domain/src/Delivery/Domain/Dsl.hs b/delivery/delivery-domain/src/Delivery/Domain/Dsl.hs new file mode 100644 index 0000000..cc2aad1 --- /dev/null +++ b/delivery/delivery-domain/src/Delivery/Domain/Dsl.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GADTs #-} + +module Delivery.Domain.Dsl + ( DeliveryScript, + DeliveryF (..), + get, + ) +where + +import Control.Monad.Free (Free (..)) +import Core.Drone (Drone) +import Core.Fsl (Fsl (..)) +import Core.Interpreter (eval) +import Files.Dsl (File, ResourceScript) +import Logs.Dsl (LoggerScript) + +data DeliveryF a where + Get :: + LoggerScript () -> + ResourceScript [File] -> + ([File] -> [Drone]) -> + ([Drone] -> a) -> + DeliveryF a + +instance Functor DeliveryF where + fmap f (Get log' res' h g) = Get log' res' h (f . g) + +type DeliveryScript = Free DeliveryF + +get :: + LoggerScript () -> + ResourceScript [File] -> + ([File] -> [Drone]) -> + DeliveryScript [Drone] +get log' resource' f = do + Free $ Get log' resource' f pure diff --git a/location/location-adapter/location-adapter.cabal b/location/location-adapter/location-adapter.cabal index fae2b96..b2f1be7 100644 --- a/location/location-adapter/location-adapter.cabal +++ b/location/location-adapter/location-adapter.cabal @@ -21,6 +21,7 @@ library exposed-modules: Location.Adapter.Config.LocationConfig Location.Adapter.Repository + Location.Adapter.Interpreter other-modules: Paths_location_adapter hs-source-dirs: @@ -29,6 +30,7 @@ library async , base >= 4.7 && < 5 , MissingH + , free , envs , logs , files diff --git a/location/location-adapter/src/Location/Adapter/Interpreter.hs b/location/location-adapter/src/Location/Adapter/Interpreter.hs new file mode 100644 index 0000000..76518c2 --- /dev/null +++ b/location/location-adapter/src/Location/Adapter/Interpreter.hs @@ -0,0 +1,29 @@ +module Location.Adapter.Interpreter where + +import Control.Monad.Free (Free (..)) +import Core.Drone (Drone) +import Files.Dsl (File) +import Files.Interpreter (ResourceInterpreter, resourceInterpret) +import Location.Domain.Dsl (LocationF (..), LocationScript) +import Logs.Interpreter (LoggerInterpreter, loggerInterpret) + +class Monad m => LocationInterpreter m where + onPut :: () -> m () + +instance LocationInterpreter IO where + onPut r = return r + +locationInterpret :: + ( Monad m, + ResourceInterpreter m, + LoggerInterpreter m, + LocationInterpreter m + ) => + LocationScript a -> + m a +locationInterpret (Pure a) = return a +locationInterpret (Free (Put l r next)) = do + _ <- loggerInterpret l + r <- resourceInterpret r + v <- onPut r + locationInterpret (next v) diff --git a/location/location-application/location-application.cabal b/location/location-application/location-application.cabal index acdcbe1..3c71734 100644 --- a/location/location-application/location-application.cabal +++ b/location/location-application/location-application.cabal @@ -20,12 +20,15 @@ extra-source-files: CHANGELOG.md library exposed-modules: Location.Application.Location + Location.Application.Dsl other-modules: Paths_location_application hs-source-dirs: src build-depends: base >= 4.7 && < 5 - , core-s4n + , free + , core-s4n + , logs , location-domain default-language: Haskell2010 diff --git a/location/location-application/src/Location/Application/Dsl.hs b/location/location-application/src/Location/Application/Dsl.hs new file mode 100644 index 0000000..10883e0 --- /dev/null +++ b/location/location-application/src/Location/Application/Dsl.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE GADTs #-} + +module Location.Application.Dsl where + +import Control.Monad.Free (Free (..)) +import Core.Drone (Drone) +import Location.Domain.Dsl (LocationScript) +import Logs.Dsl (LoggerScript) + +data LocationA a where + Put :: + LoggerScript () -> + LocationScript () -> + (() -> a) -> + LocationA a + +instance Functor LocationA where + fmap f (Put log res g) = Put log res (f . g) + +type LocationAScript = Free LocationA + +put :: + LoggerScript () -> + LocationScript () -> + LocationAScript () +put logs' loc' = + Free $ Put logs' loc' pure diff --git a/location/location-domain/location-domain.cabal b/location/location-domain/location-domain.cabal index fc36fe7..8a10103 100644 --- a/location/location-domain/location-domain.cabal +++ b/location/location-domain/location-domain.cabal @@ -20,11 +20,16 @@ extra-source-files: CHANGELOG.md library exposed-modules: Location.Domain.Repository + Location.Domain.Dsl + Location.Domain.Configuration.Config other-modules: Paths_location_domain hs-source-dirs: src build-depends: base >= 4.7 && < 5 + , free , core-s4n + , logs + , files default-language: Haskell2010 diff --git a/location/location-domain/src/Location/Domain/Configuration/Config.hs b/location/location-domain/src/Location/Domain/Configuration/Config.hs new file mode 100644 index 0000000..53a9479 --- /dev/null +++ b/location/location-domain/src/Location/Domain/Configuration/Config.hs @@ -0,0 +1,14 @@ +module Location.Domain.Configuration.Config + ( LocationConfig (..), + config, + ) +where + +data LocationConfig = LocationConfig + { outPath :: String, + prefix :: String, + extension :: String + } + +config :: String -> String -> String -> LocationConfig +config = LocationConfig diff --git a/location/location-domain/src/Location/Domain/Dsl.hs b/location/location-domain/src/Location/Domain/Dsl.hs new file mode 100644 index 0000000..19cc2e9 --- /dev/null +++ b/location/location-domain/src/Location/Domain/Dsl.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs #-} + +module Location.Domain.Dsl + ( LocationScript, + LocationF (..), + put, + ) +where + +import Control.Monad.Free (Free (..)) +import Core.Drone (Drone) +import Files.Dsl (File, ResourceScript) +import Logs.Dsl (LoggerScript) + +data LocationF a where + Put :: + LoggerScript () -> + ResourceScript () -> + (() -> a) -> + LocationF a + +instance Functor LocationF where + fmap f (Put log res g) = Put log res (f . g) + +type LocationScript a = Free LocationF a + +put :: + LoggerScript () -> + ResourceScript () -> + LocationScript () +put logs' resource' = + Free $ Put logs' resource' pure diff --git a/package.yaml b/package.yaml index 0313aad..12d998f 100644 --- a/package.yaml +++ b/package.yaml @@ -23,8 +23,10 @@ dependencies: - base >= 4.7 && < 5 - hspec - exceptions + - free - katip >= 0.1.0.0 && < 0.8.6.0 - QuickCheck + - mtl - envs - logs - files diff --git a/prueba-s4n-haskell.cabal b/prueba-s4n-haskell.cabal index c72b47a..adf2c2a 100644 --- a/prueba-s4n-haskell.cabal +++ b/prueba-s4n-haskell.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 854afc96d3d0e8d20c1ae2f70f8f976aca72e5158577b8797c366bd1d3f675f8 +-- hash: 7384f0833e521e4ba8ee7c69f54632a2f8be0bd0d7fce1e282334c38c1286ed3 name: prueba-s4n-haskell version: 0.1.0.0 @@ -28,6 +28,8 @@ source-repository head library exposed-modules: App + AppF + Env other-modules: Paths_prueba_s4n_haskell hs-source-dirs: @@ -42,12 +44,14 @@ library , envs , exceptions , files + , free , hspec , katip >=0.1.0.0 && <0.8.6.0 , location-adapter , location-application , location-domain , logs + , mtl default-language: Haskell2010 executable prueba-s4n-haskell-exe @@ -67,12 +71,14 @@ executable prueba-s4n-haskell-exe , envs , exceptions , files + , free , hspec , katip >=0.1.0.0 && <0.8.6.0 , location-adapter , location-application , location-domain , logs + , mtl , prueba-s4n-haskell default-language: Haskell2010 @@ -94,11 +100,13 @@ test-suite prueba-s4n-haskell-test , envs , exceptions , files + , free , hspec , katip >=0.1.0.0 && <0.8.6.0 , location-adapter , location-application , location-domain , logs + , mtl , prueba-s4n-haskell default-language: Haskell2010 diff --git a/src/AppF.hs b/src/AppF.hs new file mode 100644 index 0000000..685e8db --- /dev/null +++ b/src/AppF.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} + +module AppF where + +import Control.Monad.Free (Free (..), foldFree) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Core.Drone (Drone, Position (..), drone, origin) +import qualified Core.Fsl as Core +import qualified Core.Interpreter as CI +import qualified Delivery.Adapter.Interpreter as DI +import qualified Delivery.Domain.Configuration.Config as DC +import qualified Delivery.Domain.Dsl as Dsl +import qualified Files.Dsl as Fsl +import qualified Files.Interpreter as FI +import qualified Logs.Dsl as Lsl +import qualified Logs.Interpreter as LI +import System.IO (FilePath) + +--data AppM a = AppM { runAppM :: ReaderT Env IO a } + +data AppF a where + EvalLogger :: Lsl.LoggerScript () -> (() -> a) -> AppF a + GetFiles :: Fsl.ResourceScript [Fsl.File] -> ([Fsl.File] -> a) -> AppF a + WriteFile :: Fsl.ResourceScript () -> (() -> a) -> AppF a + CreateDirectory :: Fsl.ResourceScript FilePath -> (FilePath -> a) -> AppF a + BasicProgram :: Dsl.DeliveryScript [Drone] -> ([Drone] -> a) -> AppF a + +instance Functor AppF where + fmap f (EvalLogger l g) = EvalLogger l (f . g) + fmap f (GetFiles r g) = GetFiles r (f . g) + fmap f (WriteFile r g) = WriteFile r (f . g) + fmap f (CreateDirectory r g) = CreateDirectory r (f . g) + fmap f (BasicProgram d g) = BasicProgram d (f . g) + +type AppScript a = Free AppF a + +evalLogger :: String -> AppScript () +evalLogger msj = Free $ EvalLogger (Lsl.logger Lsl.mkInfo (Lsl.mkLogCtx "Example") (Lsl.mkLogMsg msj)) pure + +getFiles :: String -> Fsl.Directory -> Fsl.Extension -> AppScript [Fsl.File] +getFiles msj dir ext = do + let loggerS = Lsl.logger Lsl.mkInfo (Lsl.mkLogCtx "Example") (Lsl.mkLogMsg msj) + Free $ GetFiles (Fsl.get loggerS dir ext) pure + +writeFile :: String -> Fsl.File -> Fsl.Directory -> AppScript () +writeFile msj file dir = do + let loggerS = Lsl.logger Lsl.mkInfo (Lsl.mkLogCtx "Example") (Lsl.mkLogMsg msj) + Free $ WriteFile (Fsl.put loggerS file dir) pure + +createDirectory :: String -> Fsl.Directory -> AppScript FilePath +createDirectory msj dir = do + let loggerS = Lsl.logger Lsl.mkInfo (Lsl.mkLogCtx "Example") (Lsl.mkLogMsg msj) + Free $ CreateDirectory (Fsl.create loggerS dir) pure + +basicProgram :: String -> DC.DeliveryConfig -> AppScript [Drone] +basicProgram msj config' = do + let loggerS = Lsl.logger Lsl.mkInfo (Lsl.mkLogCtx "Example") (Lsl.mkLogMsg msj) + directory' = Fsl.mkDirectory (DC.inPath config') + extension' = Fsl.mkCustom (DC.extension config') + resourceS = Fsl.get loggerS directory' extension' + Free $ BasicProgram (Dsl.get loggerS resourceS filesToDrones) pure + +filesToDrones :: [Fsl.File] -> [Drone] +filesToDrones [] = [] +filesToDrones files' = fileToDrone <$> files' + +fileToDrone :: Fsl.File -> Drone +fileToDrone (Fsl.File (Fsl.Filename name) lines') = + drone name (toPosition lines') + where + toPosition :: [Fsl.Line] -> [Position] + toPosition [] = [] + toPosition lines' = lineToPosition <$> lines' + lineToPosition :: Fsl.Line -> Position + lineToPosition (Fsl.Line line') = makePosition line' + makePosition :: String -> Position + makePosition v = + let fsl = Core.makeFsl v + in case fsl of + Right s -> CI.eval s + _ -> origin + +interpret :: forall a. AppF a -> IO a +interpret (EvalLogger l next) = next <$> LI.loggerInterpret l +interpret (GetFiles r next) = next <$> FI.resourceInterpret r +interpret (WriteFile r next) = next <$> FI.resourceInterpret r +interpret (CreateDirectory r next) = next <$> FI.resourceInterpret r +interpret (BasicProgram d next) = next <$> DI.deliveryInterpret d + +runApp :: AppScript a -> IO a +runApp = foldFree interpret diff --git a/src/Env.hs b/src/Env.hs new file mode 100644 index 0000000..8a48e10 --- /dev/null +++ b/src/Env.hs @@ -0,0 +1,11 @@ +module Env where + +import Delivery.Adapter.Config.DeliveryConfig (DeliveryConfig) +import Location.Adapter.Config.LocationConfig (LocationConfig) +import Logs.Config.LogConfig (LogConfig) + +data Env = Env + { logs :: LogConfig, + location :: LocationConfig, + delivery :: DeliveryConfig + }