Merge remote-tracking branch 'origin/master'

app/astro/Astro/Client/Common.hs

@@ -30,6 +30,7 @@ data Approach
   | RT    -- ^ ReaderT
   | FM    -- ^ Free Monad
   | FT    -- ^ Final Tagless (mtl-style)
+  | FT2   -- ^ Final Tagless 2 (mtl-style)
   | CEFM  -- ^ Church Encoded Free Monad
   | GADT  -- ^ GADT
   deriving (Show, Read)

app/astro/Astro/Client/FinalTagless2.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Astro.Client.FinalTagless2
+  ( consoleApp
+  , HttpAstroService
+  , TcpAstroService
+  ) where
+
+import           Hydra.Prelude
+import qualified Data.ByteString.Lazy  as BSL
+
+import qualified Hydra.Domain          as D
+import qualified Hydra.Language        as L
+
+import qualified Astro.API             as API
+import           Astro.Domain.Meteor   (MeteorId, Meteors)
+import           Astro.Domain.Asteroid (AsteroidId)
+import           Astro.Client.Common   (ReportChannel(..))
+import qualified Astro.Client.Common   as C
+
+
+class AstroService k m where
+  reportMeteor     :: Proxy k -> API.MeteorTemplate   -> m (Either BSL.ByteString MeteorId)
+  reportAsteroid   :: Proxy k -> API.AsteroidTemplate -> m (Either BSL.ByteString AsteroidId)
+
+data HttpAstroService
+data TcpAstroService
+
+instance AstroService HttpAstroService L.AppL where
+  reportMeteor   _ = C.reportMeteorHttp C.localhostAstro
+  reportAsteroid _ = C.reportAsteroidHttp C.localhostAstro
+
+instance AstroService TcpAstroService L.AppL where
+  reportMeteor   _ = C.reportMeteorTcp C.tcpConn
+  reportAsteroid _ = C.reportAsteroidTcp C.tcpConn
+
+
+reportWith
+  :: FromJSON obj
+  => (obj -> L.AppL (Either BSL.ByteString res))
+  -> (Either BSL.ByteString obj)
+  -> L.AppL (Either BSL.ByteString ())
+reportWith _        (Left err)  = pure $ Left err
+reportWith reporter (Right obj) = reporter obj >> pure (Right ())
+
+consoleApp
+  :: forall k
+   . AstroService k L.AppL
+  => L.AppL ()
+consoleApp = do
+  line <- L.evalIO $ BSL.putStr "> " >> BSL.getContents
+
+  let runners =
+        [ reportWith (reportMeteor $ Proxy @k)   $ C.tryParseCmd @(API.MeteorTemplate)   line
+        , reportWith (reportAsteroid $ Proxy @k) $ C.tryParseCmd @(API.AsteroidTemplate) line
+        ]
+
+  eResults <- sequence runners
+  C.printResults eResults
+
+  consoleApp @k

app/astro/Main.hs

@@ -17,6 +17,7 @@ import qualified Astro.Client.ServiceHandle as SH
 import qualified Astro.Client.ReaderT       as RT
 import qualified Astro.Client.FreeMonad     as FM
 import qualified Astro.Client.FinalTagless  as FT
+import qualified Astro.Client.FinalTagless2 as FT2
 import qualified Astro.Client.GADT          as GADT
 
 
@@ -31,6 +32,8 @@ runAstroClient appr ch = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt
     app'' GADT _ = GADT.consoleApp $ GADT.getAstroServiceRunner ch
     app'' FT   HttpChannel = FT.consoleApp FT.httpAstroService
     app'' FT   TcpChannel  = FT.consoleApp FT.tcpAstroService
+    app'' FT2  HttpChannel = FT2.consoleApp @(FT2.HttpAstroService)
+    app'' FT2  TcpChannel  = FT2.consoleApp @(FT2.TcpAstroService)
     app'' _ _    = error $ "Approach not yet implemented: " <> show appr
 
 getChannel :: String -> ReportChannel
@@ -41,7 +44,7 @@ getChannel ch     = error $ show $ "Channel not supported: " <> ch <> " Supporte
 getApproach :: String -> Approach
 getApproach apprStr = case readMaybe apprStr of
   Just appr -> appr
-  Nothing   -> error $ show $ "Approach not supported: " <> apprStr <> " Supported: SH RT FM FT GADT"
+  Nothing   -> error $ show $ "Approach not supported: " <> apprStr <> " Supported: SH RT FM FT FT2 GADT"
 
 main :: IO ()
 main = do