summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-02-16 21:00:12 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-02-16 21:00:12 -0400
commit483f5a8c4d9e069b4c461998caa9efc9376c9133 (patch)
tree4ee66d202f9055e98a34f557c84f537924b84bd6
parentdd5933f2125c3167990a72a82b9280c4a87ede3e (diff)
add another quickcheck property, and several edge cases handled
-rw-r--r--Annex/View.hs74
-rw-r--r--Test.hs1
-rw-r--r--Types/MetaData.hs6
3 files changed, 73 insertions, 8 deletions
diff --git a/Annex/View.hs b/Annex/View.hs
index 3ac22a6d8..9b5bb0989 100644
--- a/Annex/View.hs
+++ b/Annex/View.hs
@@ -57,6 +57,17 @@ multiValue (FilterValues s) = S.size s > 1
multiValue (FilterGlob _ _) = True
#endif
+{- Each multivalued ViewFilter in a view results in another level of
+ - subdirectory nesting. When a file matches multiple ways, it will appear
+ - in multiple subdirectories. This means there is a bit of an exponential
+ - blowup with a single file appearing in a crazy number of places!
+ -
+ - Capping the view size to 5 is reasonable; why wants to dig
+ - through 5+ levels of subdirectories to find anything?
+ -}
+viewTooLarge :: View -> Bool
+viewTooLarge view = length (filter (multiValue . snd) view) > 5
+
type FileView = FilePath
type MkFileView = FilePath -> FileView
@@ -85,15 +96,24 @@ nonEmptyList s
- in some way. However, the branch's directory structure is not relevant
- in the view.
-
- - So, from dir/subdir/file.foo, generate file(dir)(subdir).foo
+ - So, from dir/subdir/file.foo, generate file{dir}{subdir}.foo
+ -
+ - (To avoid collisions with a filename that already contains {foo},
+ - that is doubled to {{foo}}.)
-}
fileViewFromReference :: MkFileView
-fileViewFromReference f = base ++ concatMap (\d -> "(" ++ d ++ ")") dirs ++ concat extensions
+fileViewFromReference f = concat
+ [ double base
+ , concatMap (\d -> "{" ++ double d ++ "}") dirs
+ , double $ concat extensions
+ ]
where
(path, basefile) = splitFileName f
dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
(base, extensions) = splitShortExtensions basefile
+ double = replace "{" "{{" . replace "}" "}}"
+
{- Generates views for a file from a branch, based on its metadata
- and the filename used in the branch.
-
@@ -106,8 +126,8 @@ fileViewFromReference f = base ++ concatMap (\d -> "(" ++ d ++ ")") dirs ++ conc
fileViews :: View -> MkFileView -> FilePath -> MetaData -> [FileView]
fileViews view mkfileview file metadata
| any isNothing matches = []
- | otherwise = map (</> mkfileview file) $
- pathProduct $ map (map fromMetaValue) $ visible matches
+ | otherwise = map (</> mkfileview file) $ pathProduct $
+ map (map toViewPath) (visible matches)
where
matches :: [Maybe [MetaValue]]
matches = map (uncurry $ matchFilter metadata) view
@@ -116,6 +136,37 @@ fileViews view mkfileview file metadata
filter (multiValue . fst) .
zip (map snd view)
+toViewPath :: MetaValue -> FilePath
+toViewPath = concatMap escapeslash . fromMetaValue
+ where
+ escapeslash c
+ | c == '/' = [pseudoSlash]
+ | c == '\\' = [pseudoBackslash]
+ | c == pseudoSlash = [pseudoSlash, pseudoSlash]
+ | c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
+ | otherwise = [c]
+
+fromViewPath :: FilePath -> MetaValue
+fromViewPath = toMetaValue . deescapeslash []
+ where
+ deescapeslash s [] = reverse s
+ deescapeslash s (c:cs)
+ | c == pseudoSlash = case cs of
+ (c':cs')
+ | c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
+ _ -> deescapeslash ('/':s) cs
+ | c == pseudoBackslash = case cs of
+ (c':cs')
+ | c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
+ _ -> deescapeslash ('/':s) cs
+ | otherwise = deescapeslash (c:s) cs
+
+pseudoSlash :: Char
+pseudoSlash = '\8725' -- '∕' /= '/'
+
+pseudoBackslash :: Char
+pseudoBackslash = '\9586' -- '╲' /= '\'
+
pathProduct :: [[FilePath]] -> [FilePath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
@@ -130,7 +181,20 @@ fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values)
visible = filter (multiValue . snd) view
fields = map fst visible
paths = splitDirectories $ dropFileName f
- values = map toMetaValue paths
+ values = map fromViewPath paths
+
+{- Constructing a view that will match arbitrary metadata, and applying
+ - it to a file yields a set of FileViews which all contain the same
+ - MetaFields that were present in the input metadata
+ - (excluding fields that are not multivalued). -}
+prop_view_roundtrips :: FilePath -> MetaData -> Bool
+prop_view_roundtrips f metadata = null f || viewTooLarge view ||
+ all hasfields (fileViews view fileViewFromReference f metadata)
+ where
+ view = map (\(mf, mv) -> (mf, FilterValues $ S.filter (not . null . fromMetaValue) mv))
+ (fromMetaData metadata)
+ visiblefields = sort (map fst $ filter (multiValue . snd) view)
+ hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
{- Generates a git branch name for a View.
-
diff --git a/Test.hs b/Test.hs
index c5d047875..64ec11074 100644
--- a/Test.hs
+++ b/Test.hs
@@ -149,6 +149,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
, testProperty "prop_metadata_sane" Types.MetaData.prop_metadata_sane
, testProperty "prop_metadata_serialize" Types.MetaData.prop_metadata_serialize
, testProperty "prop_branchView_legal" Annex.View.prop_branchView_legal
+ , testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips
]
{- These tests set up the test environment, but also test some basic parts
diff --git a/Types/MetaData.hs b/Types/MetaData.hs
index d8184a768..248a96abb 100644
--- a/Types/MetaData.hs
+++ b/Types/MetaData.hs
@@ -8,9 +8,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Types.MetaData (
- MetaData,
- MetaField,
- MetaValue,
+ MetaData(..),
+ MetaField(..),
+ MetaValue(..),
CurrentlySet(..),
serialize,
deserialize,