Use clock sets instead of lists

exe-t4-commands/Commands.hs

@@ -4,7 +4,7 @@ import T4.Data
 import T4.Storage
 import T4.Report
 import qualified Util as U
-import Data.List
+import qualified Data.Set as S
 import Data.Map
 import Data.Time
 import Options.Applicative
@@ -82,17 +82,18 @@ addClock clock = do
 
 handle :: Command -> IO ()
 handle (CmdIn c ts) = do  cslt <- U.getCurrentSLT
-                          addClock $ In cslt c ts
+                          addClock $ In cslt c (S.fromList ts)
 handle CmdOut       = do  cslt <- U.getCurrentSLT
                           addClock $ Out cslt
 handle CmdStatus    = do  clocks <- getClocks
-                          putStrLn $ case clocks of
-                            [] -> "No clock data yet"
-                            cs -> summary $ last cs
+                          putStrLn $
+                            if S.null clocks
+                              then "No clock data yet"
+                              else summary (S.findMax clocks)
 handle CmdCats      = do  clocks <- getClocks
-                          mapM_ putStrLn (sort $ allCategories clocks)
+                          mapM_ putStrLn $ allCategories clocks
 handle CmdTags      = do  clocks <- getClocks
-                          mapM_ putStrLn (sort $ allTags clocks)
+                          mapM_ putStrLn $ allTags clocks
 handle (CmdReport t obl man secs) = do
   clocks <- getClocks
   let durMap = (if t then tagDurations else categoryDurations) clocks
@@ -101,7 +102,7 @@ handle (CmdReport t obl man secs) = do
 printDurMap :: Bool -> Bool -> Bool -> Map String NominalDiffTime -> IO ()
 printDurMap o n s = mapM_ putStrLn . showDurMap o n s
 
-getClocks :: IO [Clock]
+getClocks :: IO Clocks
 getClocks = loadDataFromDir =<< getStorageDirectory
 
 main :: IO ()

exe-t5-interactive/TUI.hs

@@ -7,14 +7,15 @@ import Data.Char
 import Data.List
 import Data.Maybe
 import Data.Function
+import qualified Data.Set as S
 import Data.Map (Map)
 import Data.Time
 import qualified System.Console.Haskeline as H
 
 main :: IO ()
 main = do
   sdir  <- getStorageDirectory
-  clock <- lastMaybe <$> loadDataFromDir sdir
+  clock <- findMax <$> loadDataFromDir sdir
   showState clock
   newClock <- if isJust clock && isIn (fromJust clock)
                 then promptIn (time $ fromJust clock)
@@ -23,6 +24,7 @@ main = do
     Nothing -> showState clock
     Just c  -> do addClockToDir sdir c
                   showState (Just c)
+  where findMax = fmap fst . S.maxView
 
 showState :: Maybe Clock -> IO ()
 showState = putStrLn . maybe "No clock data yet" summary
@@ -68,7 +70,7 @@ clockIn = do
   mtags <- runWithCompletion tagsCompl $ H.getInputLine "Tags: "
   return $ In now (parseCat mc) (parseTags mtags)
   where parseCat  = fmap $ dropWhile isSpace . dropWhileEnd isSpace
-        parseTags = map (dropWhile (== '#')) . words . fromMaybe ""
+        parseTags = S.fromList . map (dropWhile (== '#')) . words . fromMaybe ""
 
 report :: String -> Map String NominalDiffTime -> IO ()
 report prefix durMap = do

lib/Completion.hs

@@ -3,22 +3,24 @@ module Completion where
 import Data.Char
 import Data.List
 import Data.Function
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified System.Console.Haskeline.Completion as HC
 
 data Completion a = Compl
-  { complItems    :: [a]
+  { complItems    :: Set a
   , complToString :: a -> String
   }
 
 complMatch :: String -> String -> Bool
 complMatch = isSubsequenceOf `on` map toLower
 
-complete :: Completion a -> String -> [a]
-complete (Compl xs toStr) cs = filter (complMatch cs . toStr) xs
+complete :: Completion a -> String -> Set a
+complete (Compl xs toStr) cs = S.filter (complMatch cs . toStr) xs
 
 haskelineCompletions :: Completion a -> String -> [HC.Completion]
 haskelineCompletions c@(Compl _ toString) =
-  map (HC.simpleCompletion . toString) . complete c
+  map (HC.simpleCompletion . toString) . S.toList . complete c
 
 haskelineCompletionFunc :: Monad m => Completion a -> HC.CompletionFunc m
 haskelineCompletionFunc =

lib/T4/Data.hs

@@ -4,8 +4,10 @@ import Data.Char
 import Data.Function
 import Data.Maybe
 import qualified Data.Text as T
-import qualified Data.List.NonEmpty as NE
-import Data.List.Extra
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Time
 import Data.Aeson
 import Data.Aeson.TH
@@ -39,7 +41,7 @@ type Tag      = String
 
 data Clock  = In  { time      :: SimpleLocalTime
                   , category  :: Maybe Category
-                  , tags      :: [Tag]
+                  , tags      :: Set Tag
                   }
             | Out { time      :: SimpleLocalTime
                   }
@@ -68,11 +70,14 @@ summary (In t mc ts)  = "IN (" ++ sltString t ++ ")" ++ catStr ++ tagsStr
   where catStr  = maybe "" ((" [" ++) . (++ "]")) mc
         tagsStr = concatMap (" #" ++) ts
 
-dayGroups :: [Clock] -> [NE.NonEmpty Clock]
-dayGroups = map NE.fromList . groupOn getDay . sort
+type Clocks = Set Clock
 
-allCategories :: [Clock] -> [Category]
-allCategories = nubOrd . mapMaybe category . filter isIn
+dayGroups :: Clocks -> Map Day Clocks
+dayGroups = foldr combine M.empty
+  where combine = M.insertWith S.union <$> getDay <*> S.singleton
 
-allTags :: [Clock] -> [Tag]
-allTags = nubOrd . concatMap tags . filter isIn
+allCategories :: Clocks -> Set Category
+allCategories = S.fromList . mapMaybe category . S.toList . S.filter isIn
+
+allTags :: Clocks -> Set Tag
+allTags = S.unions . S.map tags . S.filter isIn

lib/T4/Report.hs

@@ -3,18 +3,19 @@ module T4.Report where
 import T4.Data
 import Util
 import Data.List
+import qualified Data.Set as S
 import Data.Map
 import Data.Time
 
-categoryDurations :: [Clock] -> Map Category NominalDiffTime
+categoryDurations :: Clocks -> Map Category NominalDiffTime
 categoryDurations = durations select
-  where select (In t (Just c) _)  = ([c], getLocalTime t)
-        select c                  = ([],  getLocalTime $ time c)
+  where select (In t (Just c) _)  = (S.singleton c, getLocalTime t)
+        select c                  = (S.empty,       getLocalTime $ time c)
 
-tagDurations :: [Clock] -> Map Tag NominalDiffTime
+tagDurations :: Clocks -> Map Tag NominalDiffTime
 tagDurations = durations select
-  where select (In t _ ts)  = (ts,  getLocalTime t)
-        select c            = ([],  getLocalTime $ time c)
+  where select (In t _ ts)  = (ts,      getLocalTime t)
+        select c            = (S.empty, getLocalTime $ time c)
 
 showDurMap :: Bool -> Bool -> Bool -> Map String NominalDiffTime -> [String]
 showDurMap bySnd natural secs m =

lib/T4/Storage.hs

@@ -2,8 +2,8 @@ module T4.Storage where
 
 import T4.Data
 import Data.List
-import qualified Data.List.NonEmpty as NE
 import Data.Maybe
+import qualified Data.Set as S
 import Data.Yaml
 import Text.Regex.TDFA
 import System.FilePath
@@ -14,23 +14,23 @@ import Control.Monad.Extra
 fileName :: Clock -> FilePath
 fileName clock = dateString (time clock) <.> "yml"
 
-loadDataFromDir :: FilePath -> IO [Clock]
+loadDataFromDir :: FilePath -> IO Clocks
 loadDataFromDir dir = do
   ymlFiles <- filter (".yml" `isSuffixOf`) <$> listDirectory dir
-  sort <$> concatMapM decodeFileThrow ((dir </>) <$> ymlFiles)
+  S.fromList <$> concatMapM decodeFileThrow ((dir </>) <$> ymlFiles)
 
-writeDataToDir :: FilePath -> [Clock] -> IO ()
+writeDataToDir :: FilePath -> Clocks -> IO ()
 writeDataToDir dir clocks = do
   forM_ (dayGroups clocks) $ \dayGroup -> do
-    encodeFile (dir </> fileName (NE.head dayGroup)) dayGroup
+    encodeFile (dir </> fileName (S.findMin dayGroup)) dayGroup
 
 addClockToDir :: FilePath -> Clock -> IO ()
 addClockToDir dir clock = do
   let file = dir </> fileName clock
-  other <- ifM (doesFileExist file)
-                  (decodeFileThrow file)
-                  (return [])
-  writeDataToDir dir (clock : other)
+  other <- S.fromList <$> ifM (doesFileExist file)
+                            (decodeFileThrow file)
+                            (return [])
+  writeDataToDir dir $ S.insert clock other
 
 getStorageDirectoryPath :: IO FilePath
 getStorageDirectoryPath = do

lib/Util.hs

@@ -3,21 +3,20 @@ module Util where
 import T4.Data (SimpleLocalTime(SLT))
 import Data.List
 import Data.Foldable
-import Data.Bifunctor
+import Data.Set (Set)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Time
 
 durations :: (Ord a, Show a, Foldable f)
-          => (entry -> ([a], LocalTime))
+          => (entry -> (Set a, LocalTime))
           -> f entry
           -> Map a NominalDiffTime
 durations extract xs =
-  let entries = sortOn snd $ extract' <$> toList xs
-      durs    = concat $ zipWith pairDuration entries (drop 1 entries)
-  in  foldr (uncurry $ M.insertWith (+)) M.empty durs
-  where extract' = first nub . extract
-        pairDuration (ys, t1) (_, t2) = (, diffLocalTime t2 t1) <$> ys
+  let entries = sortOn snd $ extract <$> toList xs
+      durs    = zipWith pairDur entries (drop 1 entries)
+  in  foldr (M.unionWith (+)) M.empty durs
+  where pairDur (ys, t1) (_, t2) = M.fromSet (const $ diffLocalTime t2 t1) ys
 
 newtype DurationConfig  = DurConf { units :: [DurationUnit] }
                                   deriving (Eq, Show)
@@ -69,7 +68,3 @@ showRoughDiffTime dc = showDiffTimeSplits . init . splitDiffTime dc
 
 getCurrentSLT :: IO SimpleLocalTime
 getCurrentSLT = SLT . zonedTimeToLocalTime <$> getZonedTime
-
-lastMaybe :: [a] -> Maybe a
-lastMaybe [] = Nothing
-lastMaybe xs = Just (last xs)

test/CompletionSpec.hs

@@ -7,7 +7,9 @@ import Test.QuickCheck
 import Completion
 import Data.Char
 import Data.String ()
-import Data.List
+import Data.List hiding ((\\))
+import Data.Set ((\\))
+import qualified Data.Set as S
 import Data.Functor.Identity
 import qualified System.Console.Haskeline.Completion as HC
 
@@ -39,41 +41,43 @@ spec = do
 
   context "Completion suggestion" $ do
 
-    let items = ["foo bar", "foo baz", "qoux"]
-        compl = Compl (Identity <$> items) runIdentity
+    let items = S.fromList ["foo bar", "foo baz", "qoux"]
+        compl = Compl items id
     it "Empty -> all suggestions" $
-      complete compl "" `shouldBe` (Identity <$> items)
+      complete compl "" `shouldBe` items
     it "'o' -> 3/3" $
-      complete compl "o" `shouldBe` (Identity <$> items)
+      complete compl "o" `shouldBe` items
     it "'f ba' -> 2/3" $
-      complete compl "f ba" `shouldBe` (Identity <$> ["foo bar", "foo baz"])
+      complete compl "f ba"
+        `shouldBe` S.fromList ["foo bar", "foo baz"]
     it "'f bar' -> 1/3" $
-      complete compl "f bar" `shouldBe` [Identity "foo bar"]
+      complete compl "f bar"
+        `shouldBe` S.singleton "foo bar"
     it "'f barz' -> 0/3" $
-      complete compl "f barz" `shouldBe` []
+      complete compl "f barz" `shouldBe` S.empty
 
     describe "Arbitrary completion" $ do
 
       prop "Suggestions match" $ \aitems ->
         forAll (genShortSublists $ concat aitems) $ \str ->
           let suggestions = complete (Compl aitems id) str
           in  not (null suggestions) ==>
-              forAll (elements suggestions) $ \sugg ->
+              forAll (elements $ S.toList suggestions) $ \sugg ->
                 complMatch str sugg `shouldBe` True
 
       prop "Not-suggestions don't match" $ \aitems ->
         forAll (genShortSublists $ concat aitems) $ \str ->
           let nopes = aitems \\ complete (Compl aitems id) str
           in  not (null nopes) ==>
-              forAll (elements nopes) $ \nope ->
+              forAll (elements $ S.toList nopes) $ \nope ->
                 complMatch str nope `shouldBe` False
 
   context "Haskeline completion" $ do
 
     describe "Completion list generation" $ do
 
       it "Basic transformation" $
-        haskelineCompletions (Compl ["foo"] id) "fo"
+        haskelineCompletions (Compl (S.singleton "foo") id) "fo"
           `shouldBe` [HC.Completion "foo" "foo" True]
 
       prop "Replacement = Display" $
@@ -94,7 +98,7 @@ spec = do
       prop "Same completion list" $
         forAll genMatchPairs $ \(compl, match) ->
           map HC.display (haskelineCompletions compl match)
-            `shouldBe` complete compl match
+            `shouldBe` S.toList (complete compl match)
 
     describe "Completion function transformation" $ do
 
@@ -106,7 +110,7 @@ spec = do
           in  runIdentity result `shouldBe` ("", compls)
 
       describe "Examples with word completion" $ do
-        let compl     = Compl (words "foo bar baz") id
+        let compl     = Compl (S.fromList $ words "foo bar baz") id
             complf    = haskelineCompletionFunc compl
             hcompl w  = HC.Completion w w True
         it "First word" $ runIdentity (complf ("f", ""))
@@ -131,24 +135,20 @@ genShortSublists xs = do
 genCompletions :: Gen (Completion String)
 genCompletions = do
   ws <- listOf $ listOf $ arbitrary `suchThat` (not . isSpace)
-  return $ Compl ws id
-
-notEmpty :: [a] -> Bool
-notEmpty = not . null
-noEmpty :: [[a]] -> Bool
-noEmpty = (&&) <$> notEmpty <*> all notEmpty
+  return $ Compl (S.fromList ws) id
 
 genMatches :: Completion a -> Gen String
 genMatches (Compl ws toString) = do
-  str <- (toString <$> elements ws) `suchThat` notEmpty
-  sublistOf str `suchThat` notEmpty
+  str <- (toString <$> elements (S.toList ws)) `suchThat` (not . null)
+  sublistOf str `suchThat` (not . null)
 
 genMatchPairs :: Gen (Completion String, String)
 genMatchPairs = do
-  compl <- genCompletions `suchThat` (noEmpty . complItems)
+  compl <- genCompletions `suchThat` (notEmpty . complItems)
   match <- genMatches compl
   return (compl, match)
+  where notEmpty = (&&) <$> not . null <*> (not . any null)
 
 instance Show (Completion a) where
   show (Compl items toString) =
-    "Compl (complItems=" ++ show (toString <$> items) ++ ")"
+    "Compl (complItems=" ++ show (toString <$> S.toList items) ++ ")"