{-# LANGUAGE OverloadedStrings #-}
module MsgGen where
import Control.Applicative
import Control.Monad (zipWithM)
import Control.Monad.IO.Class
import Control.Monad.State (evalStateT)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Gen (generateMsgType, generateSrvTypes)
import MD5 (msgMD5, srvMD5)
import Parse (parseMsg, parseSrv)
import ResolutionTypes (emptyMsgContext, alterPkgMap, MsgInfo)
import Ros.Internal.DepFinder (findMessages)
import System.FilePath ((</>), dropExtension, takeFileName)
import Test.Tasty
import Test.Tasty.HUnit

-- CONSTANTS

  | The location of  message definitions .
actionDir :: FilePath
actionDir = "Tests/actionlib_msgs"

  | The location of    files .
goldenDir :: FilePath
goldenDir = "Tests/actionlib_msgs/golden"

-- HELPER FUNCTIONS

-- | Manually add a package and its message definitions to the cache.
cachePkg :: FilePath -> MsgInfo ()
cachePkg dir =
  do msgFiles <- liftIO $ findMessages dir
     let msgNames = map (B.pack . dropExtension . takeFileName) msgFiles
         pkg = (dir, M.empty, M.fromList . zip msgNames $ map Left msgFiles)
         pkgName = B.pack $ takeFileName dir
     alterPkgMap (M.insert pkgName pkg)

-- | Prepare the cache with the std_msgs and rosgraph_msgs packages.
prepMsgGen :: MsgInfo ()
prepMsgGen = do cachePkg "Tests/std_msgs"
                cachePkg "Tests/rosgraph_msgs"

--TEST GENERATORS

  | Test that the generated  code matches a golden  file
  The first argument is a path to the test directory
  The second argument is a list of paths to the message file
  The third argument is a list of paths to the golden Haskell file
-- Precondition: cachePkg has been called
testGeneratedHaskell :: B.ByteString -> [FilePath] -> [FilePath] -> [B.ByteString] -> MsgInfo TestTree
testGeneratedHaskell packagePath msgPaths haskellPaths pkgMsgs =
  do msgs <- liftIO $ mapM (fmap (either error id) . parseMsg) msgPaths
     golds <- liftIO $ mapM B.readFile haskellPaths
     gens <- mapM (generateMsgType packagePath pkgMsgs) msgs
     return $ testGroup "Generated Haskell" $ zipWith3
       (\name gold gen -> testCase name $ gold @=? gen) msgPaths golds gens

  | @testGeneratedService packagePath srvPath requestGolden responseGolden pkgMsgs@ tests a service defined at @srvPath@
testGeneratedService :: B.ByteString -> FilePath -> FilePath -> FilePath -> [B.ByteString] -> MsgInfo TestTree
testGeneratedService packagePath srvPath requestGolden responseGolden pkgMsgs =
  do srv <- liftIO $
            either error id <$> parseSrv srvPath
     golds <- liftIO $ mapM B.readFile [requestGolden, responseGolden]
     (request, response) <- generateSrvTypes packagePath pkgMsgs srv
     return $ testGroup "Generated Haskell" $ zipWith3
       (\name gold gen -> testCase name $ gold @=? gen) [srvPath ++" request", srvPath++" response"] golds [request, response]
     

-- | Precondition: cachePkg has been called
testMD5 :: FilePath -> String -> MsgInfo TestTree
testMD5 msgPath  md5 =
  do msg <- liftIO $ 
             either error id <$> parseMsg msgPath
     genMD5 <- msgMD5 msg
     return $ testCase ("MD5 for " ++ msgPath) $ md5 @=? genMD5

testSrvMD5 :: FilePath -> String -> MsgInfo TestTree
testSrvMD5 srvPath md5 =
  do srv <- liftIO $ 
             either error id <$> parseSrv srvPath
     genMD5 <- srvMD5 srv
     return $ testCase ("MD5 for " ++ srvPath) $ md5 @=? genMD5

-- TESTS

testActionMsgs :: MsgInfo TestTree
testActionMsgs =
  do cachePkg actionDir
     md5TestList <- zipWithM testMD5 msgFiles md5s
     let md5Tests = testGroup "MD5s" md5TestList
     genTests <- testGeneratedHaskell "Ros.Actionlib_msgs." msgFiles haskellFiles (map B.pack msgNames)
     return $ testGroup "actionlib_msgs" [md5Tests, genTests]
  where -- Message names and the corresponding MD5s computed by rosmsg
    msgNames = map fst msgDefs
    md5s = map snd msgDefs
    msgFiles = map (((actionDir</>"msg")</>) . (++".msg")) msgNames
    haskellFiles =  map ((goldenDir </>) . (++".hs")) msgNames
    msgDefs = [ ("GoalID", "302881f31927c1df708a2dbab0e80ee8")
              , ("GoalStatus", "d388f9b87b3c471f784434d671988d4a")
              , ("GoalStatusArray", "8b2b82f13216d0a8ea88bd3af735e619") ]

-- | Test a message definition that includes string constants.
testStringMsg :: MsgInfo TestTree
testStringMsg = do
  let testDir = "Tests/test_msgs"
      messageFile = "Tests/test_msgs/msg/StringConst.msg"
      haskellFile = "Tests/test_msgs/golden/StringConst.hs"
  cachePkg testDir
  gen <- testGeneratedHaskell "Ros.Test_msgs." [messageFile] [haskellFile] ["StringConsts"]
  md5 <- testMD5 messageFile "a8e1a25e612660c2e8d3d161e9e91950"
  return $ testGroup "String constants" [gen, md5]

Test that the MD5 for a service is generated correctly
addTwoIntsServiceMD5 :: MsgInfo TestTree
addTwoIntsServiceMD5 = do
  cachePkg testDir
  md5Test <- testSrvMD5 file md5
  return $ testGroup "Services" [md5Test]
  where
    testDir = "Tests/test_srvs"
    file = "Tests/test_srvs/srv/AddTwoInts.srv"
    md5 = "6a2e34150c00229791cc89ff309fff21"

addTwoIntsGen :: MsgInfo TestTree
addTwoIntsGen = do
  cachePkg testDir
  genTests <- testGeneratedService "Ros.Test_srvs." srvFile requestFile responseFile []
  return $ testGroup "Add Two Ints srv gen" [genTests]
  where
    testDir = "Tests/test_srvs"
    srvFile = "Tests/test_srvs/srv/AddTwoInts.srv"
    requestFile = "Tests/test_srvs/golden/AddTwoIntsRequest.hs"
    responseFile = "Tests/test_srvs/golden/AddTwoIntsResponse.hs"

emptySrv :: MsgInfo TestTree
emptySrv = do
  cachePkg testDir
  genTests <- testGeneratedService "Ros.Test_srvs."srvFile requestFile responseFile []
  md5Test <- testSrvMD5 srvFile md5
  return $ testGroup "empty srv gen" [genTests, md5Test]
  where
    md5 = "d41d8cd98f00b204e9800998ecf8427e"
    testDir = "Tests/test_srvs"
    srvFile = "Tests/test_srvs/srv/Empty.srv"
    requestFile = "Tests/test_srvs/golden/EmptyRequest.hs"
    responseFile = "Tests/test_srvs/golden/EmptyResponse.hs"

-- | ROOT TEST

-- | Tests for message generation.
tests :: IO TestTree
tests =
  fmap (testGroup "Message generation") $
  do testList <- flip evalStateT emptyMsgContext $
              do prepMsgGen
                 sequence [testActionMsgs
                          , testStringMsg
                          , addTwoIntsServiceMD5
                          , addTwoIntsGen
                          , emptySrv]
     return testList

# LANGUAGE OverloadedStrings #
 CONSTANTS
 HELPER FUNCTIONS
 | Manually add a package and its message definitions to the cache.
 | Prepare the cache with the std_msgs and rosgraph_msgs packages.
TEST GENERATORS
 Precondition: cachePkg has been called
 | Precondition: cachePkg has been called
 TESTS
 Message names and the corresponding MD5s computed by rosmsg
 | Test a message definition that includes string constants.
 | ROOT TEST
 | Tests for message generation.
module MsgGen where
import Control.Applicative
import Control.Monad (zipWithM)
import Control.Monad.IO.Class
import Control.Monad.State (evalStateT)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Gen (generateMsgType, generateSrvTypes)
import MD5 (msgMD5, srvMD5)
import Parse (parseMsg, parseSrv)
import ResolutionTypes (emptyMsgContext, alterPkgMap, MsgInfo)
import Ros.Internal.DepFinder (findMessages)
import System.FilePath ((</>), dropExtension, takeFileName)
import Test.Tasty
import Test.Tasty.HUnit


  | The location of  message definitions .
actionDir :: FilePath
actionDir = "Tests/actionlib_msgs"

  | The location of    files .
goldenDir :: FilePath
goldenDir = "Tests/actionlib_msgs/golden"


cachePkg :: FilePath -> MsgInfo ()
cachePkg dir =
  do msgFiles <- liftIO $ findMessages dir
     let msgNames = map (B.pack . dropExtension . takeFileName) msgFiles
         pkg = (dir, M.empty, M.fromList . zip msgNames $ map Left msgFiles)
         pkgName = B.pack $ takeFileName dir
     alterPkgMap (M.insert pkgName pkg)

prepMsgGen :: MsgInfo ()
prepMsgGen = do cachePkg "Tests/std_msgs"
                cachePkg "Tests/rosgraph_msgs"


  | Test that the generated  code matches a golden  file
  The first argument is a path to the test directory
  The second argument is a list of paths to the message file
  The third argument is a list of paths to the golden Haskell file
testGeneratedHaskell :: B.ByteString -> [FilePath] -> [FilePath] -> [B.ByteString] -> MsgInfo TestTree
testGeneratedHaskell packagePath msgPaths haskellPaths pkgMsgs =
  do msgs <- liftIO $ mapM (fmap (either error id) . parseMsg) msgPaths
     golds <- liftIO $ mapM B.readFile haskellPaths
     gens <- mapM (generateMsgType packagePath pkgMsgs) msgs
     return $ testGroup "Generated Haskell" $ zipWith3
       (\name gold gen -> testCase name $ gold @=? gen) msgPaths golds gens

  | @testGeneratedService packagePath srvPath requestGolden responseGolden pkgMsgs@ tests a service defined at @srvPath@
testGeneratedService :: B.ByteString -> FilePath -> FilePath -> FilePath -> [B.ByteString] -> MsgInfo TestTree
testGeneratedService packagePath srvPath requestGolden responseGolden pkgMsgs =
  do srv <- liftIO $
            either error id <$> parseSrv srvPath
     golds <- liftIO $ mapM B.readFile [requestGolden, responseGolden]
     (request, response) <- generateSrvTypes packagePath pkgMsgs srv
     return $ testGroup "Generated Haskell" $ zipWith3
       (\name gold gen -> testCase name $ gold @=? gen) [srvPath ++" request", srvPath++" response"] golds [request, response]
     

testMD5 :: FilePath -> String -> MsgInfo TestTree
testMD5 msgPath  md5 =
  do msg <- liftIO $ 
             either error id <$> parseMsg msgPath
     genMD5 <- msgMD5 msg
     return $ testCase ("MD5 for " ++ msgPath) $ md5 @=? genMD5

testSrvMD5 :: FilePath -> String -> MsgInfo TestTree
testSrvMD5 srvPath md5 =
  do srv <- liftIO $ 
             either error id <$> parseSrv srvPath
     genMD5 <- srvMD5 srv
     return $ testCase ("MD5 for " ++ srvPath) $ md5 @=? genMD5


testActionMsgs :: MsgInfo TestTree
testActionMsgs =
  do cachePkg actionDir
     md5TestList <- zipWithM testMD5 msgFiles md5s
     let md5Tests = testGroup "MD5s" md5TestList
     genTests <- testGeneratedHaskell "Ros.Actionlib_msgs." msgFiles haskellFiles (map B.pack msgNames)
     return $ testGroup "actionlib_msgs" [md5Tests, genTests]
    msgNames = map fst msgDefs
    md5s = map snd msgDefs
    msgFiles = map (((actionDir</>"msg")</>) . (++".msg")) msgNames
    haskellFiles =  map ((goldenDir </>) . (++".hs")) msgNames
    msgDefs = [ ("GoalID", "302881f31927c1df708a2dbab0e80ee8")
              , ("GoalStatus", "d388f9b87b3c471f784434d671988d4a")
              , ("GoalStatusArray", "8b2b82f13216d0a8ea88bd3af735e619") ]

testStringMsg :: MsgInfo TestTree
testStringMsg = do
  let testDir = "Tests/test_msgs"
      messageFile = "Tests/test_msgs/msg/StringConst.msg"
      haskellFile = "Tests/test_msgs/golden/StringConst.hs"
  cachePkg testDir
  gen <- testGeneratedHaskell "Ros.Test_msgs." [messageFile] [haskellFile] ["StringConsts"]
  md5 <- testMD5 messageFile "a8e1a25e612660c2e8d3d161e9e91950"
  return $ testGroup "String constants" [gen, md5]

Test that the MD5 for a service is generated correctly
addTwoIntsServiceMD5 :: MsgInfo TestTree
addTwoIntsServiceMD5 = do
  cachePkg testDir
  md5Test <- testSrvMD5 file md5
  return $ testGroup "Services" [md5Test]
  where
    testDir = "Tests/test_srvs"
    file = "Tests/test_srvs/srv/AddTwoInts.srv"
    md5 = "6a2e34150c00229791cc89ff309fff21"

addTwoIntsGen :: MsgInfo TestTree
addTwoIntsGen = do
  cachePkg testDir
  genTests <- testGeneratedService "Ros.Test_srvs." srvFile requestFile responseFile []
  return $ testGroup "Add Two Ints srv gen" [genTests]
  where
    testDir = "Tests/test_srvs"
    srvFile = "Tests/test_srvs/srv/AddTwoInts.srv"
    requestFile = "Tests/test_srvs/golden/AddTwoIntsRequest.hs"
    responseFile = "Tests/test_srvs/golden/AddTwoIntsResponse.hs"

emptySrv :: MsgInfo TestTree
emptySrv = do
  cachePkg testDir
  genTests <- testGeneratedService "Ros.Test_srvs."srvFile requestFile responseFile []
  md5Test <- testSrvMD5 srvFile md5
  return $ testGroup "empty srv gen" [genTests, md5Test]
  where
    md5 = "d41d8cd98f00b204e9800998ecf8427e"
    testDir = "Tests/test_srvs"
    srvFile = "Tests/test_srvs/srv/Empty.srv"
    requestFile = "Tests/test_srvs/golden/EmptyRequest.hs"
    responseFile = "Tests/test_srvs/golden/EmptyResponse.hs"


tests :: IO TestTree
tests =
  fmap (testGroup "Message generation") $
  do testList <- flip evalStateT emptyMsgContext $
              do prepMsgGen
                 sequence [testActionMsgs
                          , testStringMsg
                          , addTwoIntsServiceMD5
                          , addTwoIntsGen
                          , emptySrv]
     return testList
