{-# LANGUAGE DeriveAnyClass, FlexibleInstances, ScopedTypeVariables, DeriveGeneric, StandaloneDeriving, OverloadedStrings #-}
module Ham.Internal.CAT where
import Control.Monad (when)
import Control.Monad.Trans.RWS
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class
import Control.Exception
import Data.Aeson
import qualified Data.ByteString.Char8 as B
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Text (Text)
import GHC.Generics
import Ham.CAT.SerialCAT
import Ham.CAT.Radios
import Ham.Internal.Data
import System.Hardware.Serialport
data CATConfig = CATConfig { catPort :: String
, catRadio :: Radio
, catSerialSettings :: SerialPortSettings
} deriving (Generic, Show)
deriving instance Show SerialPortSettings
deriving instance Generic SerialPortSettings
deriving instance Generic CommSpeed
deriving instance Generic FlowControl
deriving instance Generic StopBits
deriving instance Generic Parity
instance FromJSON SerialPortSettings
instance ToJSON SerialPortSettings
instance FromJSON CommSpeed
instance ToJSON CommSpeed
instance FromJSON FlowControl
instance ToJSON FlowControl
instance FromJSON StopBits
instance ToJSON StopBits
instance FromJSON Parity
instance ToJSON Parity
instance FromJSON CATConfig
instance ToJSON CATConfig
instance FromJSON Radio
instance ToJSON Radio
defaultConfig :: CATConfig
defaultConfig = CATConfig { catPort = "/dev/ttyUSB0"
, catRadio = YaesuFT891
, catSerialSettings = defaultSerialSettings { commSpeed = CS4800
, bitsPerWord = fromIntegral 8
, stopb = One
, parity = NoParity
, flowControl = NoFlowControl
, timeout = 2 } }
data CATState = CATState { statePort :: Maybe SerialPort
, stateInterface :: SerialCAT
}
defaultState :: CATState
defaultState = CATState { statePort = Nothing
, stateInterface = yaesuFT891 }
data CATError = CATError CATErrorType Text deriving Show
data CATErrorType = CATErrorGeneric
| CATErrorIdentify
deriving Show
newtype CAT m a = CAT { unCAT :: RWST CATConfig [Text] CATState (ExceptT CATError m) a }
instance Monad m => Functor (CAT m) where
fmap f a = CAT $ fmap f (unCAT a)
instance Monad m => Applicative (CAT m) where
pure = CAT . pure
a <*> b = CAT $ unCAT a <*> unCAT b
instance Monad m => Monad (CAT m) where
a >>= b = CAT $ unCAT a >>= (unCAT . b)
throwCAT :: Monad m => CATError -> CAT m a
throwCAT = CAT . lift . throwE
catchCAT :: Monad m => CAT m a -> (CATError -> CAT m a) -> CAT m a
catchCAT act c = CAT $ liftCatch catchE (unCAT act) (unCAT . c)
runCAT :: MonadIO m => CATConfig
-> CATState
-> CAT m a
-> m (Either CATError (a, [Text]))
runCAT config state act = runExceptT $ evalRWST (unCAT act') config state
where
act' = do
result <- catchCAT (catInit >> act) $ \e -> catDeinit >> throwCAT e
catDeinit
return result
catInit :: MonadIO m => CAT m ()
catInit = do
result <- CAT $ do
portName <- asks catPort
serialSettings <- asks catSerialSettings
ms <- liftIO $ catch
(do { s <- openSerial portName serialSettings; return (Just s) })
(\(e :: SomeException) -> return Nothing)
get >>= \a -> put (a { statePort = ms })
case ms of
Just s -> do
ident <- serialIdentify <$> gets stateInterface
a <- liftIO $ ident s
tell $ ["Identifying configured radio: " <> T.pack (show a)]
if a
then return Nothing
else return $ Just $ CATError CATErrorIdentify "Radio was not identified as the configured one."
_ -> return $ Just (CATError CATErrorGeneric "Could not open serial port.")
case result of
Just e -> throwCAT e
_ -> return ()
catDeinit :: MonadIO m => CAT m ()
catDeinit = CAT $ do
ms <- gets statePort
maybe (return ()) (\s -> liftIO $ closeSerial s) ms
get >>= \a -> put (a { statePort = Nothing })
catFrequency :: MonadIO m => CAT m (Maybe Frequency)
catFrequency = CAT $ do
ms <- gets statePort
i <- gets stateInterface
maybe
(tell ["Could not get frequency from radio"] >> return Nothing)
(\s -> do
f <- liftIO $ serialGetFrequency i s
tell ["Got frequency " <> T.pack (show f)]
return f
)
ms
catMode :: MonadIO m => CAT m (Maybe QsoMode)
catMode = CAT $ do
ms <- gets statePort
i <- gets stateInterface
maybe
(tell ["Could not get mode from radio."] >> return Nothing)
(\s -> do
a <- liftIO $ serialGetMode i s
tell ["Got mode " <> T.pack (show a)]
return a
)
ms
catPowerSSB :: MonadIO m => CAT m (Maybe Int)
catPowerSSB = CAT $ do
ms <- gets statePort
i <- gets stateInterface
maybe (return Nothing) (\s -> liftIO $ serialGetPowerSSB i s) ms
catSetPowerSSB :: MonadIO m => Int -> CAT m ()
catSetPowerSSB power = CAT $ do
ms <- gets statePort
i <- gets stateInterface
maybe (return ()) (\s -> liftIO $ serialSetPowerSSB i s power) ms