{-# 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
newtype Version a = Version { Version a -> Word
unVersion :: Word }
deriving (Version a -> Version a -> Bool
(Version a -> Version a -> Bool)
-> (Version a -> Version a -> Bool) -> Eq (Version a)
forall a. Version a -> Version a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version a -> Version a -> Bool
$c/= :: forall a. Version a -> Version a -> Bool
== :: Version a -> Version a -> Bool
$c== :: forall a. Version a -> Version a -> Bool
Eq,Eq (Version a)
Eq (Version a)
-> (Version a -> Version a -> Ordering)
-> (Version a -> Version a -> Bool)
-> (Version a -> Version a -> Bool)
-> (Version a -> Version a -> Bool)
-> (Version a -> Version a -> Bool)
-> (Version a -> Version a -> Version a)
-> (Version a -> Version a -> Version a)
-> Ord (Version a)
Version a -> Version a -> Bool
Version a -> Version a -> Ordering
Version a -> Version a -> Version a
forall a. Eq (Version a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Version a -> Version a -> Bool
forall a. Version a -> Version a -> Ordering
forall a. Version a -> Version a -> Version a
min :: Version a -> Version a -> Version a
$cmin :: forall a. Version a -> Version a -> Version a
max :: Version a -> Version a -> Version a
$cmax :: forall a. Version a -> Version a -> Version a
>= :: Version a -> Version a -> Bool
$c>= :: forall a. Version a -> Version a -> Bool
> :: Version a -> Version a -> Bool
$c> :: forall a. Version a -> Version a -> Bool
<= :: Version a -> Version a -> Bool
$c<= :: forall a. Version a -> Version a -> Bool
< :: Version a -> Version a -> Bool
$c< :: forall a. Version a -> Version a -> Bool
compare :: Version a -> Version a -> Ordering
$ccompare :: forall a. Version a -> Version a -> Ordering
$cp1Ord :: forall a. Eq (Version a)
Ord,Int -> Version a -> ShowS
[Version a] -> ShowS
Version a -> String
(Int -> Version a -> ShowS)
-> (Version a -> String)
-> ([Version a] -> ShowS)
-> Show (Version a)
forall a. Int -> Version a -> ShowS
forall a. [Version a] -> ShowS
forall a. Version a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version a] -> ShowS
$cshowList :: forall a. [Version a] -> ShowS
show :: Version a -> String
$cshow :: forall a. Version a -> String
showsPrec :: Int -> Version a -> ShowS
$cshowsPrec :: forall a. Int -> Version a -> ShowS
Show,ReadPrec [Version a]
ReadPrec (Version a)
Int -> ReadS (Version a)
ReadS [Version a]
(Int -> ReadS (Version a))
-> ReadS [Version a]
-> ReadPrec (Version a)
-> ReadPrec [Version a]
-> Read (Version a)
forall a. ReadPrec [Version a]
forall a. ReadPrec (Version a)
forall a. Int -> ReadS (Version a)
forall a. ReadS [Version a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Version a]
$creadListPrec :: forall a. ReadPrec [Version a]
readPrec :: ReadPrec (Version a)
$creadPrec :: forall a. ReadPrec (Version a)
readList :: ReadS [Version a]
$creadList :: forall a. ReadS [Version a]
readsPrec :: Int -> ReadS (Version a)
$creadsPrec :: forall a. Int -> ReadS (Version a)
Read)
class Armored a where
version :: Version a
serializations :: Map String (APrism' ByteString a)
data ArmorMode
= SaveOnly
| TestOnly
| SaveAndTest
deriving (ArmorMode -> ArmorMode -> Bool
(ArmorMode -> ArmorMode -> Bool)
-> (ArmorMode -> ArmorMode -> Bool) -> Eq ArmorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArmorMode -> ArmorMode -> Bool
$c/= :: ArmorMode -> ArmorMode -> Bool
== :: ArmorMode -> ArmorMode -> Bool
$c== :: ArmorMode -> ArmorMode -> Bool
Eq,Eq ArmorMode
Eq ArmorMode
-> (ArmorMode -> ArmorMode -> Ordering)
-> (ArmorMode -> ArmorMode -> Bool)
-> (ArmorMode -> ArmorMode -> Bool)
-> (ArmorMode -> ArmorMode -> Bool)
-> (ArmorMode -> ArmorMode -> Bool)
-> (ArmorMode -> ArmorMode -> ArmorMode)
-> (ArmorMode -> ArmorMode -> ArmorMode)
-> Ord ArmorMode
ArmorMode -> ArmorMode -> Bool
ArmorMode -> ArmorMode -> Ordering
ArmorMode -> ArmorMode -> ArmorMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArmorMode -> ArmorMode -> ArmorMode
$cmin :: ArmorMode -> ArmorMode -> ArmorMode
max :: ArmorMode -> ArmorMode -> ArmorMode
$cmax :: ArmorMode -> ArmorMode -> ArmorMode
>= :: ArmorMode -> ArmorMode -> Bool
$c>= :: ArmorMode -> ArmorMode -> Bool
> :: ArmorMode -> ArmorMode -> Bool
$c> :: ArmorMode -> ArmorMode -> Bool
<= :: ArmorMode -> ArmorMode -> Bool
$c<= :: ArmorMode -> ArmorMode -> Bool
< :: ArmorMode -> ArmorMode -> Bool
$c< :: ArmorMode -> ArmorMode -> Bool
compare :: ArmorMode -> ArmorMode -> Ordering
$ccompare :: ArmorMode -> ArmorMode -> Ordering
$cp1Ord :: Eq ArmorMode
Ord,Int -> ArmorMode -> ShowS
[ArmorMode] -> ShowS
ArmorMode -> String
(Int -> ArmorMode -> ShowS)
-> (ArmorMode -> String)
-> ([ArmorMode] -> ShowS)
-> Show ArmorMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArmorMode] -> ShowS
$cshowList :: [ArmorMode] -> ShowS
show :: ArmorMode -> String
$cshow :: ArmorMode -> String
showsPrec :: Int -> ArmorMode -> ShowS
$cshowsPrec :: Int -> ArmorMode -> ShowS
Show,ReadPrec [ArmorMode]
ReadPrec ArmorMode
Int -> ReadS ArmorMode
ReadS [ArmorMode]
(Int -> ReadS ArmorMode)
-> ReadS [ArmorMode]
-> ReadPrec ArmorMode
-> ReadPrec [ArmorMode]
-> Read ArmorMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ArmorMode]
$creadListPrec :: ReadPrec [ArmorMode]
readPrec :: ReadPrec ArmorMode
$creadPrec :: ReadPrec ArmorMode
readList :: ReadS [ArmorMode]
$creadList :: ReadS [ArmorMode]
readsPrec :: Int -> ReadS ArmorMode
$creadsPrec :: Int -> ReadS ArmorMode
Read,Int -> ArmorMode
ArmorMode -> Int
ArmorMode -> [ArmorMode]
ArmorMode -> ArmorMode
ArmorMode -> ArmorMode -> [ArmorMode]
ArmorMode -> ArmorMode -> ArmorMode -> [ArmorMode]
(ArmorMode -> ArmorMode)
-> (ArmorMode -> ArmorMode)
-> (Int -> ArmorMode)
-> (ArmorMode -> Int)
-> (ArmorMode -> [ArmorMode])
-> (ArmorMode -> ArmorMode -> [ArmorMode])
-> (ArmorMode -> ArmorMode -> [ArmorMode])
-> (ArmorMode -> ArmorMode -> ArmorMode -> [ArmorMode])
-> Enum ArmorMode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ArmorMode -> ArmorMode -> ArmorMode -> [ArmorMode]
$cenumFromThenTo :: ArmorMode -> ArmorMode -> ArmorMode -> [ArmorMode]
enumFromTo :: ArmorMode -> ArmorMode -> [ArmorMode]
$cenumFromTo :: ArmorMode -> ArmorMode -> [ArmorMode]
enumFromThen :: ArmorMode -> ArmorMode -> [ArmorMode]
$cenumFromThen :: ArmorMode -> ArmorMode -> [ArmorMode]
enumFrom :: ArmorMode -> [ArmorMode]
$cenumFrom :: ArmorMode -> [ArmorMode]
fromEnum :: ArmorMode -> Int
$cfromEnum :: ArmorMode -> Int
toEnum :: Int -> ArmorMode
$ctoEnum :: Int -> ArmorMode
pred :: ArmorMode -> ArmorMode
$cpred :: ArmorMode -> ArmorMode
succ :: ArmorMode -> ArmorMode
$csucc :: ArmorMode -> ArmorMode
Enum,ArmorMode
ArmorMode -> ArmorMode -> Bounded ArmorMode
forall a. a -> a -> Bounded a
maxBound :: ArmorMode
$cmaxBound :: ArmorMode
minBound :: ArmorMode
$cminBound :: ArmorMode
Bounded)
data ArmorConfig = ArmorConfig
{ ArmorConfig -> ArmorMode
acArmorMode :: ArmorMode
, ArmorConfig -> String
acStoreDir :: FilePath
, ArmorConfig -> Maybe Word
acNumVersions :: Maybe Word
}
defArmorConfig :: ArmorConfig
defArmorConfig :: ArmorConfig
defArmorConfig = ArmorMode -> String -> Maybe Word -> ArmorConfig
ArmorConfig ArmorMode
SaveAndTest String
"test-data" Maybe Word
forall a. Maybe a
Nothing
testArmor
:: (Eq a, Show a, Typeable a, Armored a)
=> ArmorConfig
-> String
-> a
-> Test
testArmor :: ArmorConfig -> String -> a -> Test
testArmor ArmorConfig
ac String
valId a
val =
[Test] -> Test
TestList [ (String, APrism' ByteString a) -> Test
testIt (String, APrism' ByteString a)
s | (String, APrism' ByteString a)
s <- Map String (APrism' ByteString a)
-> [(String, APrism' ByteString a)]
forall k a. Map k a -> [(k, a)]
M.toList Map String (APrism' ByteString a)
forall a. Armored a => Map String (APrism' ByteString a)
serializations ]
where
testIt :: (String, APrism' ByteString a) -> Test
testIt (String, APrism' ByteString a)
s = Assertion -> Test
forall t. (Testable t, HasCallStack) => t -> Test
test (ArmorConfig
-> (GoldenTest a -> String)
-> String
-> (String, APrism' ByteString a)
-> a
-> Assertion
forall a.
(Eq a, Show a, Typeable a, Armored a) =>
ArmorConfig
-> (GoldenTest a -> String)
-> String
-> (String, APrism' ByteString a)
-> a
-> Assertion
testSerialization ArmorConfig
ac GoldenTest a -> String
forall a. Typeable a => GoldenTest a -> String
goldenFilePath String
valId (String, APrism' ByteString a)
s a
val)
testArmorMany
:: (Eq a, Show a, Typeable a, Armored a)
=> ArmorConfig
-> Map String a
-> Test
testArmorMany :: ArmorConfig -> Map String a -> Test
testArmorMany ArmorConfig
ac Map String a
valMap = [Test] -> Test
TestList ([Test] -> Test) -> [Test] -> Test
forall a b. (a -> b) -> a -> b
$ ((String, a) -> Test) -> [(String, a)] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> Test
forall a.
(Eq a, Show a, Typeable a, Armored a) =>
(String, a) -> Test
doOne ([(String, a)] -> [Test]) -> [(String, a)] -> [Test]
forall a b. (a -> b) -> a -> b
$ Map String a -> [(String, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map String a
valMap
where
doOne :: (String, a) -> Test
doOne (String
k,a
v) = String -> Test -> Test
TestLabel String
k (Test -> Test) -> Test -> Test
forall a b. (a -> b) -> a -> b
$ ArmorConfig -> String -> a -> Test
forall a.
(Eq a, Show a, Typeable a, Armored a) =>
ArmorConfig -> String -> a -> Test
testArmor ArmorConfig
ac String
k a
v
testSerialization
:: forall a. (Eq a, Show a, Typeable a, Armored a)
=> ArmorConfig
-> (GoldenTest a -> FilePath)
-> String
-> (String, APrism' ByteString a)
-> a
-> Assertion
testSerialization :: ArmorConfig
-> (GoldenTest a -> String)
-> String
-> (String, APrism' ByteString a)
-> a
-> Assertion
testSerialization ArmorConfig
ac GoldenTest a -> String
makeFilePath String
valName (String
sname,APrism' ByteString a
p) a
val = do
Assertion
ensureTestFileExists
Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArmorConfig -> ArmorMode
acArmorMode ArmorConfig
ac ArmorMode -> ArmorMode -> Bool
forall a. Eq a => a -> a -> Bool
/= ArmorMode
SaveOnly) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
(Word -> Assertion) -> [Word] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Version a -> Assertion
assertVersionParses (Version a -> Assertion)
-> (Word -> Version a) -> Word -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Version a
forall a. Word -> Version a
Version) [Word]
vs
where
makeGT :: Version a -> GoldenTest a
makeGT = a
-> String
-> String
-> APrism' ByteString a
-> Version a
-> GoldenTest a
forall a.
a
-> String
-> String
-> APrism' ByteString a
-> Version a
-> GoldenTest a
GoldenTest a
val String
valName String
sname APrism' ByteString a
p
curVer :: Version a
curVer :: Version a
curVer = Version a
forall a. Armored a => Version a
version
vs :: [Word]
vs = [Word] -> [Word]
forall a. [a] -> [a]
reverse [Word -> (Word -> Word) -> Maybe Word -> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word
0 (Version a -> Word
forall a. Version a -> Word
unVersion Version a
curVer Word -> Word -> Word
forall a. Num a => a -> a -> a
-) (ArmorConfig -> Maybe Word
acNumVersions ArmorConfig
ac) .. Version a -> Word
forall a. Version a -> Word
unVersion Version a
curVer]
ensureTestFileExists :: Assertion
ensureTestFileExists = do
let fp :: String
fp = ArmorConfig -> String
acStoreDir ArmorConfig
ac String -> ShowS
</> GoldenTest a -> String
makeFilePath (Version a -> GoldenTest a
makeGT Version a
curVer)
d :: String
d = ShowS
dropFileName String
fp
Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArmorConfig -> ArmorMode
acArmorMode ArmorConfig
ac ArmorMode -> ArmorMode -> Bool
forall a. Eq a => a -> a -> Bool
/= ArmorMode
TestOnly) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ do
Bool -> String -> Assertion
createDirectoryIfMissing Bool
True String
d
Bool
fileExists <- String -> IO Bool
doesFileExist String
fp
Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
fileExists) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
String -> ByteString -> Assertion
B.writeFile String
fp (AReview ByteString a -> a -> ByteString
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review (APrism' ByteString a -> Prism ByteString ByteString a a
forall s t a b. APrism s t a b -> Prism s t a b
clonePrism APrism' ByteString a
p) a
val)
assertVersionParses :: Version a -> Assertion
assertVersionParses Version a
ver = do
let fp :: String
fp = ArmorConfig -> String
acStoreDir ArmorConfig
ac String -> ShowS
</> GoldenTest a -> String
makeFilePath (Version a -> GoldenTest a
makeGT Version a
ver)
Bool
exists <- String -> IO Bool
doesFileExist String
fp
if Bool
exists
then do ByteString
bs <- String -> IO ByteString
B.readFile String
fp
case Getting (First a) ByteString a -> ByteString -> Maybe a
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (APrism' ByteString a -> Prism ByteString ByteString a a
forall s t a b. APrism s t a b -> Prism s t a b
clonePrism APrism' ByteString a
p) ByteString
bs of
Maybe a
Nothing -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
String -> Word -> ShowS
forall r. PrintfType r => String -> r
printf String
"Not backwards compatible with version %d: %s"
(Version a -> Word
forall a. Version a -> Word
unVersion Version a
ver) String
fp
Just a
v -> String -> a -> a -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual (String
"File parsed but values didn't match: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp) a
val a
v
else String -> Assertion
putStrLn (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String
"\nSkipping missing file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp
data GoldenTest a = GoldenTest
{ GoldenTest a -> a
gtTestVal :: a
, GoldenTest a -> String
gtValName :: String
, GoldenTest a -> String
gtSerializationName :: String
, GoldenTest a -> APrism' ByteString a
gtPrism :: APrism' ByteString a
, GoldenTest a -> Version a
gtVersion :: Version a
}
goldenFilePath :: Typeable a => GoldenTest a -> FilePath
goldenFilePath :: GoldenTest a -> String
goldenFilePath GoldenTest a
gt =
([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlpha String
ty, String
"-", String
h]) String -> ShowS
</>
GoldenTest a -> String
forall a. GoldenTest a -> String
gtSerializationName GoldenTest a
gt String -> ShowS
</>
String -> String -> Word -> String
forall r. PrintfType r => String -> r
printf String
"%s-%03d.test" (GoldenTest a -> String
forall a. GoldenTest a -> String
gtValName GoldenTest a
gt) (Version a -> Word
forall a. Version a -> Word
unVersion (Version a -> Word) -> Version a -> Word
forall a b. (a -> b) -> a -> b
$ GoldenTest a -> Version a
forall a. GoldenTest a -> Version a
gtVersion GoldenTest a
gt)
where
ty :: String
ty = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> TypeRep) -> a -> TypeRep
forall a b. (a -> b) -> a -> b
$ GoldenTest a -> a
forall a. GoldenTest a -> a
gtTestVal GoldenTest a
gt
h :: String
h = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
4 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Hashable a => a -> Int
hash String
ty) String
""