Feature/hierarchical free monads

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

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

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

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"

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

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

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

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)

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

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

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

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