ResolutionTypes.hs

-- |A monad within which to perform message type resolution.
module ResolutionTypes where
import Control.Monad.State
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Map (Map, insert, alter)
import qualified Data.Map as M

import Types

type MsgCache = Map ByteString (Either FilePath (SerialInfo, Msg))
type TypeCache = Map MsgType SerialInfo
type PkgCache = (FilePath, TypeCache, MsgCache)

-- Mapping from package names to a tuple of the package's directory
-- and a map from the names of message types defined in that package
-- to parsed 'Msg' values for those message types.
type PackageDefs = Map ByteString (FilePath, TypeCache, MsgCache)

-- The context in which message types are resolved is a pair of a
-- current home package (used to lookup unqualified message type
-- names) and a mapping from previously encountered message types to
-- serial info.
data MsgContext = MsgContext { homePkg   :: ByteString
                             -- ^Current package for unqualified names
                             , msgDefs   :: PackageDefs
                             -- ^Mapping from package name to directory 
                             }

-- Code snippets for use in assembling a Haskell declaration (using
-- the hType field that represents a Haskell type), RosBinary and,
-- optionally, Storable instances for a message type that contains a
-- field of this type.
data SerialInfo = SerialInfo { hType    :: ByteString
                             , putField :: ByteString
                             , getField :: ByteString
                             , size     :: Maybe ByteString } 
                  deriving Show

type MsgInfo = StateT MsgContext IO

-- | An empty 'MsgContext' from which one can begin running a
-- 'MsgInfo'.
emptyMsgContext :: MsgContext
emptyMsgContext = MsgContext B.empty M.empty

setHomePkg :: ByteString -> MsgInfo ()
setHomePkg = modify . aux
    where aux n ctxt = ctxt { homePkg = n }

setTypeInfo :: MsgType -> SerialInfo -> MsgInfo SerialInfo
setTypeInfo mt info = modify aux >> return info
    where aux ctxt = let home = homePkg ctxt
                         defs' = alter (fmap addType) home (msgDefs ctxt)
                     in ctxt { msgDefs = defs' }
          addType (p,tc,mc) = (p, insert mt info tc, mc)

-- Apply the function f to the msgDefs field of the current state.
alterPkgMap :: (PackageDefs -> PackageDefs) -> MsgInfo ()
alterPkgMap f = modify aux
    where aux ctxt = ctxt { msgDefs = f (msgDefs ctxt) }

-- Add a binding from a message type string to a parsed 'Msg' value to
-- a package's existing map.
addParsedMsg :: ByteString -> ByteString -> SerialInfo -> Msg -> MsgInfo ()
addParsedMsg pkg msgType info msg =
  do ctxt <- get
     let defs' = alter (fmap aux) pkg (msgDefs ctxt)
     put $ ctxt { msgDefs = defs' }
  where aux (p, tc, mc) = (p, tc, insert msgType (Right (info, msg)) mc)