{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Armor
  ( Version(..)
  , Armored(..)
  , ArmorMode(..)
  , ArmorConfig(..)
  , defArmorConfig
  , testArmor
  , testArmorMany
  , testSerialization
  , GoldenTest(..)
  , goldenFilePath
  ) where

------------------------------------------------------------------------------
import           Control.Lens
import           Control.Monad
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Char
import           Data.Hashable
import           Data.Map        (Map)
import qualified Data.Map        as M
import           Data.Typeable
#if !MIN_VERSION_base(4,8,0)
import           Data.Word
#endif
import           Numeric
import           System.Directory
import           System.FilePath
import           Test.HUnit.Base
import           Text.Printf
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Version numbers are simple monotonically increasing positive integers.
newtype Version a = Version { unVersion :: Word }
  deriving (Eq,Ord,Show,Read)


------------------------------------------------------------------------------
-- | Core type class for armoring types.  Includes a version and all the
-- type's serializations that you want to armor.
class Armored a where
  -- | Current version number for the data type.
  version :: Version a
  -- | Map of serializations keyed by a unique ID used to refer to each
  -- serialization. A serialization is a tuple of @(a -> ByteString)@ and
  -- @(ByteString -> Maybe a)@. Represented here as a prism.
  serializations :: Map String (APrism' ByteString a)


------------------------------------------------------------------------------
-- | The mode of operation for armor test cases.
data ArmorMode
  = SaveOnly
    -- ^ Write test files for serializations that don't have them, but don't
    -- do any tests to verify that existing files are deserialized properly.
  | TestOnly
    -- ^ Run tests to verify that existing files are deserialized properly,
    -- but don't write any missing files.
  | SaveAndTest
    -- ^ Do both the save and test phases.
  deriving (Eq,Ord,Show,Read,Enum,Bounded)


------------------------------------------------------------------------------
-- | Config data for armor tests.
data ArmorConfig = ArmorConfig
    { acArmorMode   :: ArmorMode
    , acStoreDir    :: FilePath
    -- ^ Directory where all the test serializations are stored.
    , acNumVersions :: Maybe Word
    -- ^ How many versions back to test for backwards compatibility.  A value
    -- of @Just 0@ means that it only tests that the current version satisfies
    -- @parse . render == id@.  @Just 1@ means that it will verify that the
    -- previous version can still be parse.  @Just 2@ the previous two
    -- versions, etc.  Nothing means that all versions will be tested.
    }


------------------------------------------------------------------------------
-- | Default value for ArmorConfig.
defArmorConfig :: ArmorConfig
defArmorConfig = ArmorConfig SaveAndTest "test-data" Nothing


------------------------------------------------------------------------------
-- | Tests the serialization backwards compatibility of a data type by storing
-- serialized representations in .test files to be checked into your project's
-- version control.
--
-- First, this function checks the directory 'acStoreDir' for the existence of
-- a file @foo-000.test@.  If it doesn't exist, it creates it for each
-- serialization with the serialized representation of the val parameter.
--
-- Next, it checks that the serialized formats in the most recent
-- 'acNumVersions' of the stored @.test@ files are parsable by the current
-- version of the serialization.
testArmor
    :: (Eq a, Show a, Typeable a, Armored a)
    => ArmorConfig
    -> String
    -> a
    -> Test
testArmor ac valId val =
    TestList [ testIt s | s <- M.toList serializations ]
  where
    testIt s = test (testSerialization ac goldenFilePath valId s val)


------------------------------------------------------------------------------
-- | Same as 'testArmor', but more convenient for testing several values of the
-- same type.
testArmorMany
    :: (Eq a, Show a, Typeable a, Armored a)
    => ArmorConfig
    -> Map String a
    -> Test
testArmorMany ac valMap = TestList $ map doOne $ M.toList valMap
  where
    doOne (k,v) = TestLabel k $ testArmor ac k v


------------------------------------------------------------------------------
-- | Lower level assertion function that works for a wider array of test
-- frameworks.
--
-- This function can make two different assertions. It fails if the values fail
-- to parse, and it asserts that the values are equal to the expected value.
-- This latter assertion is only done for the most recent version because
-- changes that impact the structure of a data type can result in erroneous
-- failures due to changes in the order that the test cases are generated.
--
-- In other words, if you make an innocuous change like adding a constructor and
-- start getting "values didn't match" failures, all you need to do is bump the
-- data type's version. Armor will still guarantee that those serializations
-- parse properly but the incorrect value failures will be suppressed.
testSerialization
    :: forall a. (Eq a, Show a, Typeable a, Armored a)
    => ArmorConfig
    -> (GoldenTest a -> FilePath)
    -- ^ Customizable location where the serializations will be stored. We
    -- recommend 'goldenFilePath' as a standard out-of-the-box scheme.
    -> String
    -> (String, APrism' ByteString a)
    -> a
    -> Assertion
testSerialization ac makeFilePath valName (sname,p) val = do
    ensureTestFileExists
    when (acArmorMode ac /= SaveOnly) $
      mapM_ (assertVersionParses . Version) vs
  where
    makeGT = GoldenTest val valName sname p
    curVer :: Version a
    curVer = version
    vs = reverse [maybe 0 (unVersion curVer -) (acNumVersions ac) .. unVersion curVer]
    ensureTestFileExists = do
      let fp = acStoreDir ac </> makeFilePath (makeGT curVer)
          d = dropFileName fp
      when (acArmorMode ac /= TestOnly) $ do
        createDirectoryIfMissing True d
        fileExists <- doesFileExist fp
        when (not fileExists) $
          B.writeFile fp (review (clonePrism p) val)
    assertVersionParses ver = do
        let fp = acStoreDir ac </> makeFilePath (makeGT ver)
        exists <- doesFileExist fp
        if exists
          then do bs <- B.readFile fp
                  case preview (clonePrism p) bs of
                    Nothing -> assertFailure $
                      printf "Not backwards compatible with version %d: %s"
                             (unVersion ver) fp
                    Just v -> when (ver == curVer) $
                      assertEqual ("File parsed but values didn't match: " ++ fp) val v
          else putStrLn $ "\nSkipping missing file " ++ fp

------------------------------------------------------------------------------
-- | Data structure that holds all the values needed for a golden test
data GoldenTest a = GoldenTest
  { gtTestVal :: a
  , gtValName :: String
  , gtSerializationName :: String
  , gtPrism :: APrism' ByteString a
  , gtVersion :: Version a
  }

------------------------------------------------------------------------------
-- | Constructs the FilePath where the serialization will be stored (relative to
-- the base directory defined in ArmorConfig).
--
-- This function uses typeOf as a part of the directory hierarchy to
-- disambiguate tests for different data types. typeOf can contain single
-- quotes, spaces, and parenthesis in the case of type constructors that have
-- type variables so we only take the first alphanumeric characters so that the
-- paths will be meaningful to humans and then add four characters of the type's
-- hash for disambiguation.
goldenFilePath :: Typeable a => GoldenTest a -> FilePath
goldenFilePath gt =
    (concat [takeWhile isAlpha ty, "-", h]) </>
    gtSerializationName gt </>
    printf "%s-%03d.test" (gtValName gt) (unVersion $ gtVersion gt)
  where
    ty = show $ typeOf $ gtTestVal gt
    h = take 4 $ showHex (abs $ hash ty) ""