[Haskell-cafe] Advice needed on how to improve some code

[Jeff]

Hello,

I am seeking some advice on how I might improve a bit of code.
The function in question reads and parses part of a binary protocol, storing the parsed info as it proceeds.

parseDeviceData is called by parseDevice (shown further down).

It looks to me like there should be a more concise, less repetitive way to do what
parseDeviceData does.  Any advice on this would be greatly appreciated.

  parseDeviceData :: P.Payload -> Parser P.Payload
  parseDeviceData pl =
    let
      mdm = P.dataMask ( P.payloadData pl )
    in
      ( let pld = P.payloadData pl in
        if testBit mdm ( fromEnum D.Sys )
          then
            parseDeviceSysData >>=
            ( \s -> return ( pl { P.payloadData = pld { P.sysData = Just s } } ) )
          else
            return pl ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.GPS )
                   then
                     parseDeviceGPSData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.gpsData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.GSM )
                   then
                     parseDeviceGSMData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.gsmData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.COT )
                   then
                     parseDeviceCOTData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.cotData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.ADC )
                   then
                     parseDeviceADCData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.adcData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.DTT )
                   then
                     parseDeviceDTTData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.dttData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> let pld = P.payloadData pl' in
                 if testBit mdm ( fromEnum D.OneWire )
                   then
                     parseDeviceOneWireData >>=
                     ( \s -> return ( pl' { P.payloadData = pld { P.iwdData = Just s } } ) )
                   else
                     return pl' ) >>=
      ( \pl' -> if testBit mdm ( fromEnum D.ETD )
                 then
                   parseDeviceEventData pl'
                 else
                   return pl' )

The Parser above is a Data.Binary.Strict.Get wrapped in a StateT, where the state is a top-level
structure for holding the parsed packet.

  parseDevice :: Bool -> Parser ()
  parseDevice _hasEvent =
    parseTimestamp >>=
    ( \ts ->
        if _hasEvent
          then
            lift getWord8 >>=
            ( \e -> lift getWord16be >>=
              ( \mdm ->
                  return ( P.Payload "" ( Just ts ) $
                    P.blankDevicePayloadData { P.dataMask = mdm
                                             , P.eventID = toEnum ( fromIntegral e .&. 0x7f )
                                             , P.deviceStatusFlag = testBit e 7
                                             , P.hasEvent = True
                                             } ) ) )
          else
            lift getWord16be >>=
            ( \mdm ->
                return ( P.Payload "" ( Just ts ) $
                  P.blankDevicePayloadData { P.dataMask = mdm } ) )
    ) >>=
    parseDeviceData >>=
    ( \dpl -> get >>= ( \p -> put ( p { P.payloads = dpl : P.payloads p } ) ) )


Here are the data types for the Packet and Payload:


  data Payload = Payload { imei        :: !BS.ByteString
                         , timestamp   :: Maybe Word64
                         , payloadData :: PayloadData
                         }

  data PayloadData = HeartBeatPL
                   | SMSFwdPL { smsMesg    :: !BS.ByteString }
                   | SerialPL { auxData    :: !Word8
                              , fixFlag    :: !Word8
                              , gpsCoord   :: !GPSCoord
                              , serialData :: !BS.ByteString
                              }
                   | DevicePL { hasEvent         :: !Bool
                              , deviceStatusFlag :: !Bool
                              , eventID          :: !E.EventID
                              , dataMask         :: !Word16
                              , sysData          :: Maybe DS.SysData
                              , gpsData          :: Maybe DGP.GPSData
                              , gsmData          :: Maybe DGS.GSMData
                              , cotData          :: Maybe DC.COTData
                              , adcData          :: Maybe DA.ADCData
                              , dttData          :: Maybe DD.DTTData
                              , iwdData          :: Maybe DO.OneWireData
                              , etdSpd           :: Maybe ES.SpeedEvent
                              , etdGeo           :: Maybe EG.GeoEvent
                              , etdHealth        :: Maybe EH.HealthEvent
                              , etdHarsh         :: Maybe EHD.HarshEvent
                              , etdOneWire       :: Maybe EO.OneWireEvent
                              , etdADC           :: Maybe EA.ADCEvent
                              }
                              deriving ( Show )

  data Packet = Packet { protocolVersion  :: !Word8
                       , packetType       :: !PT.PacketType
                       , deviceID         :: Maybe BS.ByteString
                       , payloads         :: ![ Payload ]
                       , crc              :: !Word16
                       }
                       deriving ( Show )

Lastly, here is the Parser monad transformer:

  module G6S.Parser where

    import Control.Monad.State.Strict
    import Data.Binary.Strict.Get
    import qualified Data.ByteString as BS

    import qualified G6S.Packet as GP

    type Parser = StateT GP.Packet Get

    runParser :: Parser a -> BS.ByteString -> Maybe a
    runParser p bs =
      let
        ( result, _ ) = runGet ( runStateT p GP.initPacket ) bs
      in
        case result of
          Right tup -> Just $ fst tup
          Left _ -> Nothing


I hope there is enough info here.

Thanks,
Jeff