1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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)
|
