Cleans excessive type annotations

12 files changed, 82 insertions, 152 deletions

diff --git a/hsm-command/Hsm/Command/Command.hs b/hsm-command/Hsm/Command/Command.hs
index 3b53287..53964c4 100644
--- a/hsm-command/Hsm/Command/Command.hs
+++ b/hsm-command/Hsm/Command/Command.hs
@@ -39,13 +39,10 @@ data Command
   | Rotate Angle Speed Int
   deriving (Binary, Generic, Read, Show)
 
-commandStream ::
-     forall es. (Log :> es, Readline :> es)
-  => S.Stream (Eff es) Command
+commandStream :: (Log :> es, Readline :> es) => S.Stream (Eff es) Command
 commandStream =
   S.mapMaybeM (parse . fromJust) $ S.takeWhile isJust $ S.repeatM readline
   where
-    parse :: String -> Eff es (Maybe Command)
     parse string =
       case readEither string of
         Left err -> logAttention_ (pack err) >> return Nothing
diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs
index 428ed50..1caa562 100644
--- a/hsm-command/Hsm/Command/Readline.hs
+++ b/hsm-command/Hsm/Command/Readline.hs
@@ -22,28 +22,19 @@ type instance DispatchOf Readline = Static S.WithSideEffects
 newtype instance S.StaticRep Readline =
   Readline H.InputState
 
-readline ::
-     forall es. (Log :> es, Readline :> es)
-  => Eff es (Maybe String)
+readline :: (Log :> es, Readline :> es) => Eff es (Maybe String)
 readline = do
   flushLogger
   Readline hdl <- S.getStaticRep
-  S.unsafeEff_ $ nextLine hdl
-  where
-    nextLine :: H.InputState -> IO (Maybe String)
-    nextLine hdl =
-      H.queryInput hdl
-        $ H.handleInterrupt (return Nothing)
-        $ H.withInterrupt
-        $ H.getInputLine "% "
+  S.unsafeEff_
+    $ H.queryInput hdl
+    $ H.handleInterrupt (return Nothing)
+    $ H.withInterrupt
+    $ H.getInputLine "% "
 
 runReadline :: (IOE :> es, Resource :> es) => Eff (Readline : es) a -> Eff es a
 runReadline action = do
-  handle <- snd <$> allocate istate H.cancelInput
+  handle <- snd <$> allocate (H.initializeInput settings) H.cancelInput
   S.evalStaticRep (Readline handle) action
   where
-    settings :: H.Settings IO
     settings = H.defaultSettings {H.historyFile = Just ".hsm_command_history"}
-    --
-    istate :: IO H.InputState
-    istate = H.initializeInput settings
diff --git a/hsm-core/Hsm/Core/Env.hs b/hsm-core/Hsm/Core/Env.hs
index 4e7986f..8ef7464 100644
--- a/hsm-core/Hsm/Core/Env.hs
+++ b/hsm-core/Hsm/Core/Env.hs
@@ -3,9 +3,9 @@ module Hsm.Core.Env
   , deriveFromYaml
   ) where
 
-import Data.Aeson (FromJSON, Result(Error, Success), Value, fromJSON)
+import Data.Aeson (FromJSON, Result(Error, Success), fromJSON)
 import Data.Aeson.Key (fromText)
-import Data.Aeson.KeyMap (KeyMap, (!?))
+import Data.Aeson.KeyMap ((!?))
 import Data.Aeson.TH (defaultOptions, deriveFromJSON, rejectUnknownFields)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, unpack)
@@ -15,13 +15,10 @@ import Language.Haskell.TH (Dec, Name, Q)
 environment :: FromJSON env => Text -> Text -> IO env
 environment name = fmap (check . fromJSON . load) . decodeFileThrow . unpack
   where
-    load :: KeyMap Value -> Value
     load keymap =
       fromMaybe
         (error $ "Service configuration for " <> unpack name <> " not found)")
         $ keymap !? fromText name
-    --
-    check :: Result env -> env
     check (Success env) = env
     check (Error str) = error str
 
diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs
index 6f9910e..d1c2f5d 100644
--- a/hsm-core/Hsm/Core/Fsm.hs
+++ b/hsm-core/Hsm/Core/Fsm.hs
@@ -39,23 +39,18 @@ fsm ::
   -> S.Stream (Eff es) o
 fsm = S.mapM (return . fromJust) . S.takeWhile isJust . S.mapM run
   where
-    exit :: Eff es (Maybe o)
     exit = do
       logAttention_ "No state returned, exiting FSM"
       return Nothing
-    --
-    push :: FsmResult i o env sta -> Eff es (Maybe o)
     push (FsmResult out sta next) = do
       put sta
       put next
       return $ Just out
-    --
-    run :: i -> Eff es (Maybe o)
     run input =
       localDomain "fsm" $ do
         FsmState name action <- get
-        sta <- get
-        env <- ask
+        sta <- get @sta
+        env <- ask @env
         logTrace_ $ "Entering state " <> name
         FsmOutput res logs <- return $ action input env sta
         localDomain name $ mapM_ logTup logs
diff --git a/hsm-core/Hsm/Core/Zmq.hs b/hsm-core/Hsm/Core/Zmq.hs
index 8c12133..2f70d48 100644
--- a/hsm-core/Hsm/Core/Zmq.hs
+++ b/hsm-core/Hsm/Core/Zmq.hs
@@ -4,7 +4,6 @@ module Hsm.Core.Zmq
   ( withSocket
   ) where
 
-import Data.Text (Text)
 import Effectful (Eff, IOE, (:>))
 import Effectful.Log (Log, LogLevel(LogTrace))
 import Effectful.Resource (Resource, allocate)
@@ -12,23 +11,19 @@ import Hsm.Core.Log (withLogIO)
 import System.ZMQ4 qualified as Z
 
 withSocket ::
-     forall t es. (Z.SocketType t, IOE :> es, Log :> es, Resource :> es)
+     (Z.SocketType t, IOE :> es, Log :> es, Resource :> es)
   => t
   -> Eff es (Z.Socket t)
 withSocket stype = withLogIO >>= bracket
   where
-    bracket :: (LogLevel -> Text -> IO ()) -> Eff es (Z.Socket t)
     bracket logIO = snd . snd <$> allocate acquire release
       where
-        acquire :: IO (Z.Context, Z.Socket t)
-        acquire = do
-          logIO LogTrace "Acquiring ZMQ context"
-          cont <- Z.context
-          sock <- Z.socket cont stype
-          return (cont, sock)
-        --
-        release :: (Z.Context, Z.Socket t) -> IO ()
-        release (cont, sock) = do
-          logIO LogTrace "Releasing ZMQ context"
-          Z.close sock
-          Z.shutdown cont
+        acquire =
+          logIO LogTrace "Acquiring ZMQ context" >> do
+            cont <- Z.context
+            sock <- Z.socket cont stype
+            return (cont, sock)
+        release (cont, sock) =
+          logIO LogTrace "Releasing ZMQ context" >> do
+            Z.close sock
+            Z.shutdown cont
diff --git a/hsm-core/Hsm/Core/Zmq/Client.hs b/hsm-core/Hsm/Core/Zmq/Client.hs
index 793841e..6093e54 100644
--- a/hsm-core/Hsm/Core/Zmq/Client.hs
+++ b/hsm-core/Hsm/Core/Zmq/Client.hs
@@ -11,6 +11,7 @@ module Hsm.Core.Zmq.Client
   , runClient
   ) where
 
+import Control.Monad (forM_)
 import Control.Monad.Loops (whileM)
 import Data.Binary (Binary)
 import Data.Text (Text, pack, unpack)
@@ -50,30 +51,23 @@ receiver = do
         <> pack (show $ body @a message)
   return $ body message
 
-receive ::
-     forall es a. (Log :> es, Client :> es, Binary a, Show a)
-  => Stream (Eff es) a
+receive :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) a
 receive = repeatM receiver
 
-poll ::
-     forall es a. (Log :> es, Client :> es, Binary a, Show a)
-  => Stream (Eff es) [a]
-poll = repeatM poller
+poll :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) [a]
+poll =
+  repeatM $ do
+    ms <- whileM newMsg receiver
+    localDomain domain
+      $ localDomain "poller"
+      $ logTrace_
+      $ pack (show $ length ms) <> " new message(s) on queue"
+    return ms
   where
-    newMsg :: Eff es Bool
     newMsg = do
       Client sock <- E.getStaticRep
       peek <- E.unsafeEff_ $ Z.poll 0 [Z.Sock sock [Z.In] Nothing]
       return $ peek /= [[]]
-    --
-    poller :: Eff es [a]
-    poller = do
-      ms <- whileM newMsg receiver
-      localDomain domain
-        $ localDomain "poller"
-        $ logTrace_
-        $ pack (show $ length ms) <> " new message(s) on queue"
-      return ms
 
 runClient ::
      forall env es a.
@@ -86,23 +80,14 @@ runClient ::
      )
   => Eff (Client : es) a
   -> Eff es a
-runClient action = withSocket Z.Sub >>= run
-  where
-    run :: Z.Socket Z.Sub -> Eff es a
-    run sock = E.evalStaticRep (Client sock) $ initialize >> action
-      where
-        connect :: Text -> Eff (Client : es) ()
-        connect = E.unsafeEff_ . Z.connect sock . unpack
-        --
-        subscribe :: Text -> Eff (Client : es) ()
-        subscribe = E.unsafeEff_ . Z.subscribe sock . encodeUtf8
-        --
-        initialize :: Eff (Client : es) ()
-        initialize =
-          localDomain domain $ do
-            logInfo_ "Initializing ZMQ client"
-            env <- ask @env
-            mapM_ connect env.subEps
-            mapM_ subscribe env.topics
-            logTrace_ $ "Listening to " <> pack (show env.subEps)
-            logTrace_ $ "Subscribed to " <> pack (show env.topics)
+runClient action =
+  withSocket Z.Sub >>= \sock ->
+    E.evalStaticRep (Client sock) $ do
+      localDomain domain $ do
+        logInfo_ "Initializing ZMQ client"
+        env <- ask @env
+        forM_ env.subEps $ E.unsafeEff_ . Z.connect sock . unpack
+        forM_ env.topics $ E.unsafeEff_ . Z.subscribe sock . encodeUtf8
+        logTrace_ $ "Listening to " <> pack (show env.subEps)
+        logTrace_ $ "Subscribed to " <> pack (show env.topics)
+      action
diff --git a/hsm-core/Hsm/Core/Zmq/Server.hs b/hsm-core/Hsm/Core/Zmq/Server.hs
index 5663cd8..2e9217b 100644
--- a/hsm-core/Hsm/Core/Zmq/Server.hs
+++ b/hsm-core/Hsm/Core/Zmq/Server.hs
@@ -47,7 +47,6 @@ send ::
   -> Eff es ()
 send = S.fold S.drain . S.mapM sender
   where
-    sender :: a -> Eff es ()
     sender payload = do
       Server sock <- E.getStaticRep
       env <- ask @env
@@ -64,18 +63,12 @@ runServer ::
      )
   => Eff (Server : es) a
   -> Eff es a
-runServer action = withSocket Z.Pub >>= run
-  where
-    run :: Z.Socket Z.Pub -> Eff es a
-    run sock = E.evalStaticRep (Server sock) $ initialize >> action
-      where
-        bind :: Text -> Eff (Server : es) ()
-        bind = E.unsafeEff_ . Z.bind sock . unpack
-        --
-        initialize :: Eff (Server : es) ()
-        initialize =
-          localDomain domain $ do
-            logInfo_ "Initializing ZMQ server"
-            env <- ask @env
-            bind env.pubEp
-            logTrace_ $ "Publishing to " <> env.pubEp
+runServer action =
+  withSocket Z.Pub >>= \sock ->
+    E.evalStaticRep (Server sock) $ do
+      localDomain domain $ do
+        logInfo_ "Initializing ZMQ server"
+        env <- ask @env
+        E.unsafeEff_ $ Z.bind sock $ unpack env.pubEp
+        logTrace_ $ "Publishing to " <> env.pubEp
+      action
diff --git a/hsm-dummy-blinker/Main.hs b/hsm-dummy-blinker/Main.hs
index cfc6654..88b7b5f 100644
--- a/hsm-dummy-blinker/Main.hs
+++ b/hsm-dummy-blinker/Main.hs
@@ -27,30 +27,25 @@ data Env = Env
 $(deriveFromYaml ''Env)
 
 stateOn :: F.FsmState () Bool Env Bool
-stateOn = F.FsmState "on" action
-  where
-    action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool
-    action _ _ sta =
-      F.FsmOutput
-        (Just $ F.FsmResult sta False stateOff)
-        [(LogInfo, "Turning on blinker")]
+stateOn =
+  F.FsmState "on" $ \_ _ sta ->
+    F.FsmOutput
+      (Just $ F.FsmResult sta False stateOff)
+      [(LogInfo, "Turning on blinker")]
 
 stateOff :: F.FsmState () Bool Env Bool
-stateOff = F.FsmState "off" action
-  where
-    action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool
-    action _ _ sta =
-      F.FsmOutput
-        (Just $ F.FsmResult sta True stateOn)
-        [(LogInfo, "Turning off blinker")]
+stateOff =
+  F.FsmState "off" $ \_ _ sta ->
+    F.FsmOutput
+      (Just $ F.FsmResult sta True stateOn)
+      [(LogInfo, "Turning off blinker")]
 
 handle ::
-     forall es. (GPIOEffect () :> es, Log :> es, Reader Env :> es)
+     (GPIOEffect () :> es, Log :> es, Reader Env :> es)
   => S.Stream (Eff es) Bool
   -> Eff es ()
 handle = S.fold S.drain . S.mapM handler
   where
-    handler :: Bool -> Eff es ()
     handler sta = do
       env <- ask @Env
       toggle sta () [env.period, 0]
diff --git a/hsm-dummy-poller/Main.hs b/hsm-dummy-poller/Main.hs
index 762d139..9f2fad9 100644
--- a/hsm-dummy-poller/Main.hs
+++ b/hsm-dummy-poller/Main.hs
@@ -27,16 +27,13 @@ data Env = Env
 $(deriveFromYaml ''Env)
 
 handle ::
-     forall es. (Concurrent :> es, Log :> es, Reader Env :> es)
+     (Concurrent :> es, Log :> es, Reader Env :> es)
   => S.Stream (Eff es) [Int]
   -> Eff es ()
 handle =
   S.fold S.drain . S.mapM (\p -> asks period >>= threadDelay >> handler p)
   where
-    receiverDomain :: Text
     receiverDomain = "receiver"
-    --
-    handler :: [Int] -> Eff es ()
     handler [] = localDomain receiverDomain $ logInfo_ "No pulse received yet"
     handler ps =
       forM_ ps $ \p ->
diff --git a/hsm-dummy-pulser/Main.hs b/hsm-dummy-pulser/Main.hs
index 48a5302..d15b616 100644
--- a/hsm-dummy-pulser/Main.hs
+++ b/hsm-dummy-pulser/Main.hs
@@ -32,19 +32,15 @@ pulse = repeatM $ asks period >>= threadDelay
 stateRun :: F.FsmState () Int Env Int
 stateRun = F.FsmState "run" action
   where
-    action :: () -> Env -> Int -> F.FsmOutput () Int Env Int
     action _ env sta =
       if sta < env.pulses
         then next
         else exit
       where
-        next :: F.FsmOutput () Int Env Int
         next =
           F.FsmOutput
             (Just $ F.FsmResult sta (succ sta) stateRun)
             [(LogInfo, "Sending pulse #" <> pack (show sta))]
-        --
-        exit :: F.FsmOutput () Int Env Int
         exit =
           F.FsmOutput
             Nothing
diff --git a/hsm-dummy-receiver/Main.hs b/hsm-dummy-receiver/Main.hs
index 78b343f..451e9c4 100644
--- a/hsm-dummy-receiver/Main.hs
+++ b/hsm-dummy-receiver/Main.hs
@@ -23,15 +23,15 @@ data Env = Env
 
 $(deriveFromYaml ''Env)
 
-handle ::
-     forall es. Log :> es
-  => S.Stream (Eff es) Int
-  -> Eff es ()
+handle :: Log :> es => S.Stream (Eff es) Int -> Eff es ()
 handle = S.fold S.drain . S.mapM handler
   where
-    handler :: Int -> Eff es ()
-    handler p =
-      localDomain "receiver" $ logInfo_ $ "Received pulse #" <> pack (show p)
+    handler =
+      localDomain "receiver"
+        . logInfo_
+        . mappend "Received pulse #"
+        . pack
+        . show
 
 -- Dummy receiver service:
 -- Proof of concept. Listens for "pulses" through ZMQ and logs each time one
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index e3deabd..bc08ef5 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -64,20 +64,12 @@ gpioset state gpios periods = do
   localDomain domain $ logTrace_ $ "Calling command: " <> pack command
   E.unsafeEff_ $ callCommand command
   where
-    command :: String
+    lineArg gpio = show gpio <> "=" <> stateStr state <> " "
     command =
       "gpioset -t"
         <> intercalate "," (show <$> periods)
         <> " "
         <> concatMap lineArg (toList gpios)
-    --
-    lineArg :: GPIO -> String
-    lineArg gpio = show gpio <> "=" <> stateStr state <> " "
-
-getGPIOs :: GPIOEffect key :> es => key -> Eff es (Set GPIO)
-getGPIOs key = do
-  GPIOEffect mapper <- E.getStaticRep
-  return $ mapper key
 
 logReport ::
      (Log :> es, Show key) => Bool -> key -> [Int] -> Set GPIO -> Eff es ()
@@ -85,7 +77,6 @@ logReport state key periods gpios = do
   localDomain domain $ logTrace_ report
   flushLogger
   where
-    report :: Text
     report =
       "Setting pins "
         <> pack (show gpios)
@@ -103,29 +94,27 @@ toggle ::
   -> [Int]
   -> Eff es ()
 toggle state key periods = do
-  gpios <- getGPIOs key
-  logReport state key periods gpios
-  gpioset state gpios periods
+  GPIOEffect mapper <- E.getStaticRep
+  set $ mapper key
+  where
+    set gpios = do
+      logReport state key periods gpios
+      gpioset state gpios periods
 
 runGPIO ::
-     forall key es a. (IOE :> es, Log :> es, Bounded key, Enum key)
+     (IOE :> es, Log :> es, Bounded key, Enum key)
   => (key -> Set GPIO)
   -> Eff (GPIOEffect key : es) a
   -> Eff es a
 runGPIO mapper action =
-  E.evalStaticRep (GPIOEffect mapper) $ finally action releaser
+  E.evalStaticRep (GPIOEffect mapper) $ finally action release
   where
-    gpios :: Set GPIO
     gpios = unions $ mapper <$> [minBound .. maxBound]
-    --
-    endReport :: Text
     endReport =
       "Setting all mapped pins "
         <> pack (show gpios)
         <> " to state "
         <> stateStr False
-    --
-    releaser :: Eff (GPIOEffect key : es) ()
-    releaser = do
+    release = do
       localDomain domain $ logTrace_ endReport
       gpioset False gpios [0]