a new Key data type with metadata

Key.hs

@@ -0,0 +1,88 @@
+{- git-annex Key data type
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Key where
+
+import Data.String.Utils
+import Test.QuickCheck
+import Data.Maybe
+import Data.List
+
+{- A Key has a unique name, is associated with a backend,
+ - and may contain other metadata. -}
+data Field = KeyName | KeyBackend | KeySize | KeyModTime
+	deriving (Eq, Ord, Show)
+newtype Key = Key [(Field, String)]
+	deriving (Eq, Ord)
+
+{- Generates a Key given a name, a backend and a list of other metadata. -}
+keyGen :: String -> String -> [(Field, String)] -> Key
+keyGen name backend meta = Key $ (KeyName, name):(KeyBackend, backend):meta
+
+{- Gets the name of a Key. -}
+keyName :: Key -> String
+keyName key = fromJust $ keyField key KeyName
+
+{- Gets the backend associated with a Key. -}
+keyBackend :: Key -> String
+keyBackend key = fromJust $ keyField key KeyBackend
+
+{- Looks up a given Field of a Key's metadata. -}
+keyField :: Key -> Field -> Maybe String
+keyField (Key meta) field =
+	if null matches
+		then Nothing
+		else Just $ snd $ head matches
+	where
+		matches = filter match meta
+		match (f, _) = f == field
+
+fieldSep :: Char
+fieldSep = ','
+
+{- Keys show as strings that are suitable for use as filenames.
+ - The name field is always shown last, and is the only field
+ - allowed to contain the fieldSep. -}
+instance Show Key where
+	show k@(Key meta) = join [fieldSep] $ map showp meta' ++ [name]
+		where
+			name = 'n':keyName k
+			meta' = sort $ (filter (\(f, _) -> f /= KeyName)) meta
+			showp (f, v) = (field f) : v
+
+			field KeyBackend = 'b'
+			field KeySize = 's'
+			field KeyModTime = 'm'
+			field f = error $ "unknown key field" ++ show f
+
+instance Read Key where
+	readsPrec _ s = [(Key (meta s []), "")]
+		where
+			meta (c:r) m = findfield c r m
+			meta [] m = m
+
+			findfield 'n' v m = (KeyName, v):m -- rest is name
+			findfield c v m = let (v', _:r) = span (/= fieldSep) v in
+				meta r (field c v' m)
+			
+			field 'b' v m = (KeyBackend, v):m
+			field 's' v m = (KeySize, v):m
+			field 'm' v m = (KeyModTime, v):m
+			field _ _ m = m -- just ignore unparseable fields
+
+-- for quickcheck
+instance Arbitrary Key where
+	arbitrary = do
+		backendname <- arbitrary
+		value <- arbitrary
+		return $ keyGen value backendname []
+
+prop_idempotent_key_read_show :: Key -> Bool
+prop_idempotent_key_read_show k
+	-- backend names will never contain the fieldSep
+	| fieldSep `elem` (keyBackend k) = True
+	| otherwise = k == (read $ show k)

test.hs

@@ -38,6 +38,7 @@ import qualified Trust
 import qualified Remotes
 import qualified Content
 import qualified Command.DropUnused
+import qualified Key
 
 main :: IO ()
 main = do
@@ -55,7 +56,7 @@ quickcheck :: Test
 quickcheck = TestLabel "quickcheck" $ TestList
 	[ qctest "prop_idempotent_deencode" Git.prop_idempotent_deencode
 	, qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
-	, qctest "prop_idempotent_key_read_show" BackendTypes.prop_idempotent_key_read_show
+	, qctest "prop_idempotent_key_read_show" Key.prop_idempotent_key_read_show
 	, qctest "prop_idempotent_shellEscape" Utility.prop_idempotent_shellEscape
 	, qctest "prop_idempotent_shellEscape_multiword" Utility.prop_idempotent_shellEscape_multiword
 	, qctest "prop_parentDir_basics" Utility.prop_parentDir_basics