{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Looper
( LooperDef(..)
, seconds
, minutes
, hours
, LooperFlags(..)
, getLooperFlags
, LooperEnvironment(..)
, getLooperEnvironment
, readLooperEnvironment
, LooperConfiguration(..)
, LooperSettings(..)
, deriveLooperSettings
, mkLooperDef
, runLoopers
, runLoopersIgnoreOverrun
, runLoopersRaw
, waitNominalDiffTime
) where
import GHC.Generics (Generic)
import Control.Applicative
import Control.Monad
import qualified System.Environment as System (getEnvironment)
import Data.Aeson
import Data.Maybe
import Data.String
import Data.Text (Text)
import Data.Time
import Options.Applicative
import Text.Read
import UnliftIO
import UnliftIO.Concurrent
data LooperDef m =
LooperDef
{ looperDefName :: Text
, looperDefEnabled :: Bool
, looperDefPeriod :: NominalDiffTime
, looperDefPhase :: NominalDiffTime
, looperDefFunc :: m ()
}
deriving (Generic)
seconds :: Double -> NominalDiffTime
seconds = realToFrac
minutes :: Double -> NominalDiffTime
minutes = seconds . (* 60)
hours :: Double -> NominalDiffTime
hours = minutes . (* 60)
data LooperFlags =
LooperFlags
{ looperFlagEnabled :: Maybe Bool
, looperFlagPhase :: Maybe Int
, looperFlagPeriod :: Maybe Int
}
deriving (Show, Eq, Generic)
getLooperFlags ::
String
-> Parser LooperFlags
getLooperFlags name =
LooperFlags <$> doubleSwitch name (unwords ["enable the", name, "looper"]) mempty <*>
option
(Just <$> auto)
(mconcat
[ long $ name <> "-phase"
, metavar "SECONDS"
, value Nothing
, help $ unwords ["the phase for the", name, "looper in seconsd"]
]) <*>
option
(Just <$> auto)
(mconcat
[ long $ name <> "-period"
, metavar "SECONDS"
, value Nothing
, help $ unwords ["the period for the", name, "looper in seconds"]
])
doubleSwitch :: String -> String -> Mod FlagFields Bool -> Parser (Maybe Bool)
doubleSwitch name helpText mods =
let enabledValue = True
disabledValue = False
defaultValue = True
in ((last . map Just) <$>
some
((flag'
enabledValue
(hidden <> internal <> long ("enable-" ++ name) <> help helpText <> mods) <|>
flag'
disabledValue
(hidden <> internal <> long ("disable-" ++ name) <> help helpText <> mods)) <|>
flag'
disabledValue
(long ("(enable|disable)-" ++ name) <>
help ("Enable/disable " ++ helpText ++ " (default: " ++ show defaultValue ++ ")") <>
mods))) <|>
pure Nothing
data LooperEnvironment =
LooperEnvironment
{ looperEnvEnabled :: Maybe Bool
, looperEnvPhase :: Maybe Int
, looperEnvPeriod :: Maybe Int
}
deriving (Show, Eq, Generic)
getLooperEnvironment ::
String
-> String
-> IO LooperEnvironment
getLooperEnvironment prefix name = readLooperEnvironment prefix name <$> System.getEnvironment
readLooperEnvironment ::
String
-> String
-> [(String, String)]
-> LooperEnvironment
readLooperEnvironment prefix name env =
let v :: IsString s => String -> Maybe s
v k = fromString <$> lookup (prefix <> k) env
r :: Read a => String -> Maybe a
r k = v k >>= readMaybe
lr :: Read a => String -> Maybe a
lr k = r $ name <> "_" <> k
in LooperEnvironment
{ looperEnvEnabled = lr "ENABLED"
, looperEnvPhase = lr "PHASE"
, looperEnvPeriod = lr "PERIOD"
}
data LooperConfiguration =
LooperConfiguration
{ looperConfEnabled :: Maybe Bool
, looperConfPhase :: Maybe Int
, looperConfPeriod :: Maybe Int
}
deriving (Show, Eq, Generic)
instance FromJSON LooperConfiguration where
parseJSON =
withObject "LooperConfiguration" $ \o ->
LooperConfiguration <$> o .:? "enabled" <*> o .:? "phase" <*> o .: "period"
data LooperSettings =
LooperSettings
{ looperSetEnabled :: Bool
, looperSetPhase :: NominalDiffTime
, looperSetPeriod :: NominalDiffTime
}
deriving (Show, Eq, Generic)
deriveLooperSettings ::
NominalDiffTime
-> NominalDiffTime
-> LooperFlags
-> LooperEnvironment
-> Maybe LooperConfiguration
-> LooperSettings
deriveLooperSettings defaultPhase defaultPeriod LooperFlags {..} LooperEnvironment {..} mlc =
let looperSetEnabled =
fromMaybe True $ looperFlagEnabled <|> looperEnvEnabled <|> (mlc >>= looperConfEnabled)
looperSetPhase =
maybe defaultPhase fromIntegral $
looperFlagPhase <|> looperEnvPhase <|> (mlc >>= looperConfPhase)
looperSetPeriod =
maybe defaultPeriod fromIntegral $
looperFlagPeriod <|> looperEnvPeriod <|> (mlc >>= looperConfPeriod)
in LooperSettings {..}
mkLooperDef ::
Text
-> LooperSettings
-> m ()
-> LooperDef m
mkLooperDef name LooperSettings {..} func =
LooperDef
{ looperDefName = name
, looperDefEnabled = looperSetEnabled
, looperDefPeriod = looperSetPeriod
, looperDefPhase = looperSetPhase
, looperDefFunc = func
}
runLoopers :: MonadUnliftIO m => [LooperDef m] -> m ()
runLoopers = runLoopersIgnoreOverrun looperDefFunc
runLoopersIgnoreOverrun ::
MonadUnliftIO m
=> (LooperDef m -> m ())
-> [LooperDef m]
-> m ()
runLoopersIgnoreOverrun = runLoopersRaw (pure ())
runLoopersRaw ::
MonadUnliftIO m
=> m ()
-> (LooperDef m -> m ())
-> [LooperDef m]
-> m ()
runLoopersRaw onOverrun runLooper =
mapConcurrently_ $ \ld@LooperDef {..} ->
when looperDefEnabled $ do
waitNominalDiffTime looperDefPhase
let loop = do
start <- liftIO $ getCurrentTime
runLooper ld
end <- liftIO $ getCurrentTime
let elapsed = diffUTCTime end start
let nextWait = looperDefPeriod - elapsed
if (nextWait < 0)
then onOverrun
else waitNominalDiffTime nextWait
loop
loop
waitNominalDiffTime :: MonadIO m => NominalDiffTime -> m ()
waitNominalDiffTime ndt = liftIO $ threadDelay $ round (toRational ndt * (1000 * 1000))