content: {-# LANGUAGE OverloadedStrings, TupleSections #-}
  -- | Parser components for the ROS message description language (@msg@
  -- files). See http://wiki.ros.org/msg for reference.
  module Parse (parseMsg, parseSrv, simpleFieldAssoc) where
  import Prelude hiding (takeWhile)
  import Control.Applicative
  import Control.Arrow ((&&&))
  import Data.Attoparsec.ByteString.Char8
  import Data.ByteString (ByteString)
  import Data.ByteString.Char8 (pack, unpack)
  import qualified Data.ByteString.Char8 as B
  import Data.Char (toLower, digitToInt)
  import Data.Either (partitionEithers)
  import Data.List (foldl')
  import System.FilePath (dropExtension, takeFileName, splitDirectories)
  import Types
  
  simpleFieldTypes :: [MsgType]
  simpleFieldTypes = [ RBool, RInt8, RUInt8, RInt16, RUInt16, RInt32, RUInt32, 
                       RInt64, RUInt64, RFloat32, RFloat64, RString, 
                       RTime, RDuration, RByte, RChar ]
  
  simpleFieldAssoc :: [(MsgType, ByteString)]
  simpleFieldAssoc = map (id &&& B.pack . map toLower . tail . show) 
                         simpleFieldTypes
  
  eatLine :: Parser ()
  eatLine = manyTill anyChar (eitherP endOfLine endOfInput) *> skipSpace
  
  parseName :: Parser ByteString
  parseName = skipSpace *> identifier <* eatLine <* try comment
  
  identifier :: Parser ByteString
  identifier = B.cons <$> letter_ascii <*> takeWhile validChar
      where validChar c = any ($ c) [isDigit, isAlpha_ascii, (== '_'), (== '/')]
  
  parseInt :: Parser Int
  parseInt = foldl' (\s x -> s*10 + digitToInt x) 0 <$> many1 digit
  
  comment :: Parser [()]
  comment = many $ skipSpace *> try (char '#' *> eatLine)
  
  simpleParser :: (MsgType, ByteString) -> Parser (ByteString, MsgType)
  simpleParser (t,b) = (, t) <$> (string b *> space *> parseName)
  
  fixedArrayParser :: (MsgType, ByteString) -> Parser (ByteString, MsgType)
  fixedArrayParser (t,b) = (\len name -> (name, RFixedArray len t)) <$>
                           (string b *> char '[' *> parseInt <* char ']') <*> 
                           (space *> parseName)
  
  varArrayParser :: (MsgType, ByteString) -> Parser (ByteString, MsgType)
  varArrayParser (t,b) = (, RVarArray t) <$> 
                         (string b *> string "[]" *> space *> parseName)
  
  userTypeParser :: Parser (ByteString, MsgType)
  userTypeParser = choice [userSimple, userVarArray, userFixedArray]
  
  userSimple :: Parser (ByteString, MsgType)
  userSimple = (\t name -> (name, RUserType t)) <$>
               identifier <*> (space *> parseName)
  
  userVarArray :: Parser (ByteString, MsgType)
  userVarArray = (\t name -> (name, RVarArray (RUserType t))) <$>
                 identifier <*> (string "[]" *> space *> parseName)
  
  userFixedArray :: Parser (ByteString, MsgType)
  userFixedArray = (\t n name -> (name, RFixedArray n (RUserType t))) <$>
                   identifier <*> 
                   (char '[' *> parseInt <* char ']') <*> 
                   (space *> parseName)
  
  -- Parse constants defined in the message
  constParser :: ByteString -> MsgType -> 
                 Parser (ByteString, MsgType, ByteString)
  constParser s x = (,x,) <$> 
                    (string s *> space *> identifier) <*> 
                    (skipSpace *> char '=' *> skipSpace *> restOfLine <* skipSpace)
      where restOfLine :: Parser ByteString
            restOfLine = pack <$> manyTill anyChar (eitherP endOfLine endOfInput)
  
  constParsers :: [Parser (ByteString, MsgType, ByteString)]
  constParsers = map (uncurry constParser . swap) simpleFieldAssoc
    where swap (x,y) = (y,x)
  
  -- String constants are parsed somewhat differently from numeric
  -- constants. For numerical constants, we drop comments and trailing
  -- spaces. For strings, we take the whole line (so comments aren't
  -- stripped).
  sanitizeConstants :: (a, MsgType, ByteString) -> (a, MsgType, ByteString)
  sanitizeConstants c@(_, RString, _) = c
  sanitizeConstants (name, t, val) = 
      (name, t, B.takeWhile (\c -> c /= '#' && not (isSpace c)) val)
  
  -- Parsers fields and constants.
  fieldParsers :: [Parser (Either (ByteString, MsgType) 
                                  (ByteString, MsgType, ByteString))]
  fieldParsers = map (comment *>) $
                 map (Right . sanitizeConstants <$>) constParsers ++ 
                 map (Left <$>) (builtIns ++ [userTypeParser])
      where builtIns = concatMap (`map` simpleFieldAssoc)
                                 [simpleParser, fixedArrayParser, varArrayParser]
  
  mkParser :: MsgName -> String -> ByteString -> Parser Msg
  mkParser sname lname txt = aux . partitionEithers <$> many (choice fieldParsers)
    where aux (fs, cs) = Msg sname lname txt
                             (map buildField fs)
                             (map buildConst cs)
  
  buildField :: (ByteString, MsgType) -> MsgField
  buildField (name,typ) = MsgField fname typ name
    where fname = B.append "_" $ sanitize name
  
  buildConst :: (ByteString, MsgType, ByteString) -> MsgConst
  buildConst (name,typ,val) = MsgConst fname typ val name
    where fname = B.map toLower $ sanitize name
  
  {-
  testMsg :: ByteString
  testMsg = "# Foo bar\n\n#   \nHeader header  # a header\nuint32 aNum # a number \n  # It's not important\ngeometry_msgs/PoseStamped[] poses\nbyte DEBUG=1 #debug level\n"
  
  test :: Result Msg
  test = feed (parse (comment *> (mkParser "" "" testMsg)) testMsg) ""
  -}
  
  -- Ensure that field and constant names are valid Haskell identifiers
  -- and do not coincide with Haskell reserved words.
  sanitize :: ByteString -> ByteString
  sanitize "data" = "_data"
  sanitize "type" = "_type"
  sanitize "class" = "_class"
  sanitize "module" = "_module"
  sanitize x = B.cons (toLower (B.head x)) (B.tail x)
  
  pkgName :: FilePath -> String
  pkgName f = let parts = splitDirectories f
                  [pkg,_,_msgFile] = drop (length parts - 3) parts
              in pkg
  
  parseMsg :: FilePath -> IO (Either String Msg)
  parseMsg fname = do msgFile <- B.readFile fname
                      let tName = msgName . dropExtension . takeFileName $ fname
                          packageName = pkgName fname
                      return $ parseMsgWithName tName packageName msgFile
  
  parseMsgWithName :: MsgName -> String -> ByteString -> Either String Msg
  parseMsgWithName name packageName msgFile =
    case feed (parse parser msgFile) "" of
      Done leftOver msg
        | B.null leftOver -> Right msg
        | otherwise -> Left $ "Couldn't parse " ++ 
                       unpack leftOver
      Fail _ _ctxt err -> Left err
      Partial _ -> Left "Incomplete msg definition"
    where
      parser = comment *> mkParser name packageName msgFile
  
  -- | Parse a service file by splitting the file into a request and a response
  -- | and parsing each part separately.
  parseSrv :: FilePath -> IO (Either String Srv)
  parseSrv fname = do
    srvFile <- B.readFile fname
    let (request, response) = splitService srvFile
        packageName = pkgName fname
        rawServiceName = dropExtension . takeFileName $ fname
    return $ do
      rqst <- parseMsgWithName (requestMsgName rawServiceName) packageName request
      resp <- parseMsgWithName (responseMsgName rawServiceName) packageName response
      return Srv{srvRequest = rqst
                , srvResponse = resp
                , srvName = msgName rawServiceName
                , srvPackage = packageName
                , srvSource = srvFile}
  
  splitService :: ByteString -> (ByteString, ByteString)
  splitService service = (request, response) where
    -- divider does not include newlines to allow it match even
    -- if there is no request or response message
    divider = "---"
    (request, dividerAndResponse) = B.breakSubstring divider service
    --Add 1 to the length of the divider to remove newline
    response = B.drop (1 + B.length divider) dividerAndResponse
  