summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LocationLog.hs61
1 files changed, 31 insertions, 30 deletions
diff --git a/LocationLog.hs b/LocationLog.hs
index 14ae88abc..9a9dad133 100644
--- a/LocationLog.hs
+++ b/LocationLog.hs
@@ -32,9 +32,7 @@ import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Map as Map
-import System.IO
import System.Directory
-import Data.Char
import System.Posix.Process
import qualified GitRepo as Git
@@ -63,8 +61,7 @@ instance Read LogStatus where
readsPrec _ _ = [(Undefined, "")]
instance Show LogLine where
- show (LogLine date status uuid) = unwords
- [(show date), (show status), uuid]
+ show (LogLine d s u) = unwords [show d, show s, u]
instance Read LogLine where
-- This parser is robust in that even unparsable log lines are
@@ -74,26 +71,25 @@ instance Read LogLine where
if (length w == 3)
then case (pdate) of
Just v -> good v
- Nothing -> undefined
- else undefined
+ Nothing -> bad
+ else bad
where
w = words string
- date = w !! 0
- status = read $ w !! 1
- uuid = w !! 2
- pdate = (parseTime defaultTimeLocale "%s%Qs" date) :: Maybe UTCTime
+ s = read $ w !! 1
+ u = w !! 2
+ pdate = (parseTime defaultTimeLocale "%s%Qs" $ w !! 0) :: Maybe UTCTime
- good v = ret $ LogLine (utcTimeToPOSIXSeconds v) status uuid
- undefined = ret $ LogLine (0) Undefined ""
+ good v = ret $ LogLine (utcTimeToPOSIXSeconds v) s u
+ bad = ret $ LogLine (0) Undefined ""
ret v = [(v, "")]
{- Log a change in the presence of a key's value in a repository,
- and returns the filename of the logfile. -}
logChange :: Git.Repo -> Key -> UUID -> LogStatus -> IO (FilePath)
-logChange repo key uuid status = do
- log <- logNow status uuid
+logChange repo key u s = do
+ line <- logNow s u
ls <- readLog logfile
- writeLog logfile (compactLog $ log:ls)
+ writeLog logfile (compactLog $ line:ls)
return logfile
where
logfile = logFile repo key
@@ -114,18 +110,18 @@ readLog file = do
{- Writes a set of lines to a log file -}
writeLog :: FilePath -> [LogLine] -> IO ()
-writeLog file lines = do
+writeLog file ls = do
pid <- getProcessID
let tmpfile = file ++ ".tmp" ++ show pid
createDirectoryIfMissing True (parentDir file)
- writeFile tmpfile $ unlines $ map show lines
+ writeFile tmpfile $ unlines $ map show ls
renameFile tmpfile file
{- Generates a new LogLine with the current date. -}
logNow :: LogStatus -> UUID -> IO LogLine
-logNow status uuid = do
+logNow s u = do
now <- getPOSIXTime
- return $ LogLine now status uuid
+ return $ LogLine now s u
{- Returns the filename of the log file for a given key. -}
logFile :: Git.Repo -> Key -> String
@@ -136,28 +132,33 @@ logFile repo key =
- the value of a key. -}
keyLocations :: Git.Repo -> Key -> IO [UUID]
keyLocations thisrepo key = do
- lines <- readLog $ logFile thisrepo key
- return $ map uuid (filterPresent lines)
+ ls <- readLog $ logFile thisrepo key
+ return $ map uuid $ filterPresent ls
{- Filters the list of LogLines to find ones where the value
- is (or should still be) present. -}
filterPresent :: [LogLine] -> [LogLine]
-filterPresent lines = filter (\l -> ValuePresent == status l) $ compactLog lines
+filterPresent ls = filter (\l -> ValuePresent == status l) $ compactLog ls
+
+type LogMap = Map.Map UUID LogLine
{- Compacts a set of logs, returning a subset that contains the current
- status. -}
compactLog :: [LogLine] -> [LogLine]
-compactLog lines = compactLog' Map.empty lines
-compactLog' map [] = Map.elems map
-compactLog' map (l:ls) = compactLog' (mapLog map l) ls
+compactLog ls = compactLog' Map.empty ls
+compactLog' :: LogMap -> [LogLine] -> [LogLine]
+compactLog' m [] = Map.elems m
+compactLog' m (l:ls) = compactLog' (mapLog m l) ls
{- Inserts a log into a map of logs, if the log has better (ie, newer)
- information about a repo than the other logs in the map -}
-mapLog map log =
+mapLog :: LogMap -> LogLine -> LogMap
+mapLog m l =
if (better)
- then Map.insert (uuid log) log map
- else map
+ then Map.insert u l m
+ else m
where
- better = case Map.lookup (uuid log) map of
- Just l -> (date l <= date log)
+ better = case Map.lookup u m of
+ Just l' -> (date l' <= date l)
Nothing -> True
+ u = uuid l