Initial commit

.gitignore

@@ -0,0 +1,5 @@
+.direnv/
+.envrc
+dist-newstyle/
+
+*.timeclock

.stylish-haskell.yaml

@@ -0,0 +1,226 @@
+# stylish-haskell configuration file
+# ==================================
+
+# The stylish-haskell tool is mainly configured by specifying steps. These steps
+# are a list, so they have an order, and one specific step may appear more than
+# once (if needed). Each file is processed by these steps in the given order.
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  # Align the right hand side of some elements.  This is quite conservative
+  # and only applies to statements where each element occupies a single
+  # line.
+  - simple_align:
+      cases: false
+      top_level_patterns: false
+      records: false
+
+  # Import cleanup
+  - imports:
+      # There are different ways we can align names and lists.
+      #
+      # - global: Align the import names and import list throughout the entire
+      #   file.
+      #
+      # - file: Like global, but don't add padding when there are no qualified
+      #   imports in the file.
+      #
+      # - group: Only align the imports per group (a group is formed by adjacent
+      #   import lines).
+      #
+      # - none: Do not perform any alignment.
+      #
+      # Default: global.
+      align: none
+
+      # The following options affect only import list alignment.
+      #
+      # List align has following options:
+      #
+      # - after_alias: Import list is aligned with end of import including
+      #   'as' and 'hiding' keywords.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                          init, last, length)
+      #
+      # - with_alias: Import list is aligned with start of alias or hiding.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                 init, last, length)
+      #
+      # - new_line: Import list starts always on new line.
+      #
+      #   > import qualified Data.List      as List
+      #   >     (concat, foldl, foldr, head, init, last, length)
+      #
+      # Default: after_alias
+      list_align: new_line
+
+      # Right-pad the module names to align imports in a group:
+      #
+      # - true: a little more readable
+      #
+      #   > import qualified Data.List       as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # - false: diff-safe
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, init,
+      #   >                                     last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # Default: true
+      pad_module_names: false
+
+      # Long list align style takes effect when import is too long. This is
+      # determined by 'columns' setting.
+      #
+      # - inline: This option will put as much specs on same line as possible.
+      #
+      # - new_line: Import list will start on new line.
+      #
+      # - new_line_multiline: Import list will start on new line when it's
+      #   short enough to fit to single line. Otherwise it'll be multiline.
+      #
+      # - multiline: One line per import list entry.
+      #   Type with constructor list acts like single import.
+      #
+      #   > import qualified Data.Map as M
+      #   >     ( empty
+      #   >     , singleton
+      #   >     , ...
+      #   >     , delete
+      #   >     )
+      #
+      # Default: inline
+      long_list_align: new_line_multiline
+
+      # Align empty list (importing instances)
+      #
+      # Empty list align has following options
+      #
+      # - inherit: inherit list_align setting
+      #
+      # - right_after: () is right after the module name:
+      #
+      #   > import Vector.Instances ()
+      #
+      # Default: inherit
+      empty_list_align: inherit
+
+      # List padding determines indentation of import list on lines after import.
+      # This option affects 'long_list_align'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      list_padding: 7
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: false
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+  # Language pragmas
+  - language_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: vertical
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: false
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: true
+
+  # Replace tabs by spaces. This is disabled by default.
+  # - tabs:
+  #     # Number of spaces to use for each tab. Default: 8, as specified by the
+  #     # Haskell report.
+  #     spaces: 8
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+  # Squash multiple spaces between the left and right hand sides of some
+  # elements into single spaces. Basically, this undoes the effect of
+  # simple_align but is a bit less conservative.
+  # - squash: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account. Default: 80.
+columns: 80
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+#
+# No language extensions are enabled by default.

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hledger-time
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import qualified MyLib (someFunc)
+
+main :: IO ()
+main = MyLib.someFunc

default.nix

@@ -0,0 +1,22 @@
+{ mkDerivation, attoparsec, base, bytestring, conduit, hedgehog
+, hedgehog-corpus, hspec, hspec-hedgehog, lib, optparse-applicative
+, temporary, text, time
+}:
+mkDerivation {
+  pname = "hledger-time";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    attoparsec base bytestring conduit optparse-applicative temporary
+    text time
+  ];
+  executableHaskellDepends = [ base ];
+  testHaskellDepends = [
+    base bytestring conduit hedgehog hedgehog-corpus hspec
+    hspec-hedgehog text time
+  ];
+  license = "unknown";
+  mainProgram = "hledger-time";
+}

flake.lock

@@ -0,0 +1,41 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1659877975,
+        "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1660639432,
+        "narHash": "sha256-2WDiboOCfB0LhvnDVMXOAr8ZLDfm3WdO54CkoDPwN1A=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "6c6409e965a6c883677be7b9d87a95fab6c3472e",
+        "type": "github"
+      },
+      "original": {
+        "id": "nixpkgs",
+        "type": "indirect"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,44 @@
+{
+  description = "hledger-time";
+
+  inputs = {
+    flake-utils = {
+      url = "github:numtide/flake-utils";
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachSystem ["x86_64-linux" "x86_64-darwin"] ( system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+        hp = pkgs.haskellPackages.override ( old: {
+          overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: {})) (f: p: {
+            hledger-time = f.callPackage ./. {};
+          });
+        });
+      in
+      rec {
+
+        packages = { inherit (hp) hledger-time; };
+
+        defaultPackage = packages.hledger-time;
+        apps.hledger-time = {
+          type = "app";
+          program = "${hp.hledger-time}/bin/hledger-time";
+        };
+        devShell = hp.shellFor {
+          packages = h: [h.hledger-time];
+          withHoogle = false;
+          buildInputs = with pkgs; [
+            entr
+            cabal-install
+            hp.hlint
+            stylish-haskell
+            ghcid
+            haskell-language-server
+            hp.graphmod
+          ];
+        };
+      }
+    );
+}

hledger-time.cabal

@@ -0,0 +1,75 @@
+cabal-version:      2.4
+name:               hledger-time
+version:            0.1.0.0
+synopsis:
+
+-- A longer description of the package.
+-- description:
+homepage:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+license:            NONE
+author:             Mats Rauhala
+maintainer:         mats.rauhala@iki.fi
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+library
+    exposed-modules:  MyLib
+                      Command
+                      Hledger.Row
+
+    -- Modules included in this library but not exported.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>=4.15.1.0
+                    , attoparsec
+                    , bytestring
+                    , text
+                    , optparse-applicative
+                    , time
+                    , conduit
+                    , directory
+    hs-source-dirs:   src
+    default-language: Haskell2010
+    ghc-options:      -Wall
+
+executable hledger-time
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:
+        base ^>=4.15.1.0,
+        hledger-time
+
+    hs-source-dirs:   app
+    default-language: Haskell2010
+    ghc-options:      -Wall -threaded
+
+test-suite hledger-time-test
+    default-language: Haskell2010
+    other-modules:    Test.Hledger.Row
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          MyLibTest.hs
+    build-depends:    base ^>=4.15.1.0
+                    , hledger-time
+                    , hspec
+                    , hspec-hedgehog
+                    , hedgehog
+                    , time
+                    , text
+                    , bytestring
+                    , hedgehog-corpus
+                    , conduit
+    ghc-options:      -Wall -threaded

src/Command.hs

@@ -0,0 +1,41 @@
+module Command
+  ( Command(..)
+  , execCommand
+  )
+  where
+
+import Options.Applicative
+       ( Parser
+       , argument
+       , command
+       , execParser
+       , fullDesc
+       , help
+       , helper
+       , info
+       , metavar
+       , progDesc
+       , str
+       , subparser
+       , (<**>)
+       )
+import Data.Text (Text)
+
+
+data Command
+  = Start FilePath Text
+  | Stop FilePath
+  deriving Show
+
+commandParser :: Parser Command
+commandParser = subparser (startCommand <> stopCommand)
+  where
+    stopCommand = command "stop" (info (Stop <$> pathParser <**> helper) (progDesc "Stop the current running task"))
+    startCommand = command "start" (info (Start <$> pathParser <*> taskParser <**> helper) (progDesc "Start a new task or replace existing"))
+    taskParser = argument str (metavar "TASK" <> help "Name of the task in 'foo.bar' format")
+    pathParser = argument str (metavar "FILE" <> help "Filepath with the clocking information")
+
+execCommand :: IO Command
+execCommand = execParser opts
+  where
+    opts = info (commandParser <**> helper) fullDesc

src/Hledger/Row.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+module Hledger.Row
+  ( Task
+  , task
+  , getTask
+  , Row(..)
+  , RowContent(..)
+  , Operation(..)
+  , encode
+  , decode
+  , encodeFile
+  , decodeFile
+  )
+  where
+
+import Conduit (ConduitT, (.|))
+import Control.Applicative ((<|>))
+import qualified Data.Attoparsec.ByteString.Char8 as P
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.Conduit.Combinators as Conduit
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time (LocalTime, defaultTimeLocale, formatTime, parseTimeM)
+
+
+newtype Task = Task { getTask :: Text }
+  deriving (Eq, Show) via Text
+
+task :: Text -> Maybe Task
+task "" = Nothing
+task x = Just $ Task x
+
+data Operation
+  = In Task
+  | Out
+  deriving (Eq, Show)
+
+data Row
+  = Row RowContent
+  | Empty
+  deriving (Show, Eq)
+
+data RowContent = RowContent
+  { rowOperation :: Operation
+  , rowTime :: LocalTime
+  }
+  deriving (Eq, Show)
+
+encode :: Row -> ByteString
+encode Empty = ""
+encode (Row (RowContent{rowOperation = In (Task t), rowTime})) =
+  "i" <> " " <>
+  BC.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" rowTime) <> " " <>
+  TE.encodeUtf8 t
+encode (Row (RowContent{rowOperation = Out, rowTime})) =
+  "o" <> " " <>
+  BC.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" rowTime)
+
+decode :: ByteString -> Either String Row
+decode = P.parseOnly ((Row <$> parseRow) <|> (Empty <$ parseEmpty))
+  where
+    parseEmpty = P.skipSpace <* P.endOfInput
+    parseRow :: P.Parser RowContent
+    parseRow = do
+      P.skipSpace
+      -- See the data model above, the operation is dependent on the task,
+      -- hence the monadic parser
+      op <- parseOp
+      time <- parseTime
+      t <- parseTask op
+      pure $ RowContent t time
+    parseOp :: P.Parser (Task -> Operation)
+    parseOp = (In <$ P.char 'i' <* P.skipSpace) <|> (const Out <$ P.char 'o' <* P.skipSpace)
+    parseTime :: P.Parser LocalTime
+    parseTime = do
+      -- I'm assuming that '2022-08-15 17:02:00' has 19 characters
+      -- The input is ByteString, but since 'parseTime' eventually wants
+      -- String, I'm decoding it first to Text while retaining the decoding
+      -- error.
+      timeStr <- either (fail . show) (pure . T.unpack) . TE.decodeUtf8' =<< P.take 19
+      P.skipSpace
+      parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S"  timeStr
+    parseTask :: (Task -> Operation) -> P.Parser Operation
+    parseTask op = do
+      either (fail . show) (pure . op . Task) . TE.decodeUtf8' =<< P.takeByteString
+
+-- | Decode a file containing the hledger clock-ins and clock-uts
+decodeFile :: Monad m => ConduitT ByteString Row m ()
+decodeFile = Conduit.linesUnboundedAscii .| Conduit.concatMap decode
+
+encodeFile :: Monad m => ConduitT Row ByteString m ()
+encodeFile = Conduit.map encode .| Conduit.unlinesAscii

src/MyLib.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module MyLib (someFunc) where
+
+import Command (Command(..), execCommand)
+import Conduit
+       (ConduitT, ResourceT, liftIO, runConduit, runResourceT, yield, (.|))
+import qualified Data.Conduit.Combinators as Conduit
+import Data.Time (getCurrentTime, getCurrentTimeZone, utcToLocalTime)
+import Hledger.Row
+import System.Directory (copyFile)
+
+update :: FilePath -> (forall i m. Monad m => ConduitT i Row m () -> ConduitT i Row m ()) -> IO ()
+update path action = runResourceT $ do
+  tempFile <- runConduit $
+    Conduit.sourceFile path .|
+    action decodeFile .|
+    encodeFile .|
+    Conduit.sinkSystemTempFile "ledger.timeclock"
+  liftIO $ copyFile tempFile path
+
+query :: FilePath -> ConduitT i Row (ResourceT IO) ()
+query path = Conduit.sourceFile path .| decodeFile
+
+someFunc :: IO ()
+someFunc = do
+  now <- utcToLocalTime <$> getCurrentTimeZone <*> getCurrentTime
+  execCommand >>= \case
+    Stop path -> update path (<> yield (stop now))
+    Start path requestedTask -> do
+      t <- maybe (error "Task name can't be empty") pure $ task requestedTask
+      -- Query the previous state
+      -- If we're clocked in, stop the previous clock before starting the new
+      -- one
+      prev <- runResourceT $ runConduit $ query path .| Conduit.last
+      case prev of
+           Just (Row (RowContent{rowOperation=In _})) ->
+             update path (\c -> c <> yield (stop now) <> yield (start now t))
+           _ -> update path (<> yield (start now t))
+  where
+    stop time = Row (RowContent Out time)
+    start time t = Row (RowContent (In t) time)
+

test/MyLibTest.hs

@@ -0,0 +1,8 @@
+module Main (main) where
+
+import Test.Hspec
+import qualified Test.Hledger.Row
+
+main :: IO ()
+main = hspec
+  Test.Hledger.Row.spec

test/Test/Hledger/Row.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
+module Test.Hledger.Row where
+
+import Data.Time
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Hledger.Row
+import Test.Hspec
+import Test.Hspec.Hedgehog
+import qualified Data.Text.Encoding as TE
+import qualified Data.Conduit.Combinators as Conduit
+import Conduit (runConduit, (.|), yield)
+import Data.Foldable (traverse_)
+import qualified Data.ByteString.Char8 as B
+import Data.Maybe (fromJust)
+
+genRow :: Gen Row
+genRow = Gen.frequency [(1, pure Empty), (9, Row <$> genContent)]
+  where
+    genContent :: Gen RowContent
+    genContent = RowContent <$> genOperation <*> genTime
+    genOperation :: Gen Operation
+    genOperation = Gen.choice [In <$> genTask, pure Out]
+    genTime :: Gen LocalTime
+    genTime = do
+      (days, tod) <- timeToDaysAndTimeOfDay . fromInteger <$> Gen.integral (Range.linear 0 1_000_000_000)
+      pure $ LocalTime (ModifiedJulianDay days) tod
+    genTask :: Gen Task
+    -- The fromJust is sensible here because the generator makes non-empty
+    -- tasks
+    genTask = fromJust . task <$> Gen.text (Range.linear 1 50) (Gen.element taskChars)
+    taskChars :: String
+    taskChars = '.' : ['a'..'z'] <> ['A'..'Z']
+
+spec :: Spec
+spec = context "Hledger.Row" $ do
+  describe "Properties of tasks" $ do
+    it "a task is never empty" $ hedgehog $ do
+      t <- forAll (task <$> Gen.text (Range.linear 0 100) Gen.unicode)
+      case t of
+           -- If the smart constructor has failed, it means it has caught something
+           Nothing -> success
+           Just t' -> assert (getTask t' /= "")
+  describe "Encoding and decoding rows" $ do
+    it "satisfies roundtripping property" $ hedgehog $ do
+      row <- forAll genRow
+      tripping row encode decode
+    it "decodes in the presence of whitespace" $ hedgehog $ do
+      row <- forAll genRow
+      whitespace <- forAll (TE.encodeUtf8 <$> Gen.text (Range.linear 0 10) (pure ' '))
+      let encoded = whitespace <> encode row
+      annotateShow encoded
+      decode encoded === pure row
+    it "doesn't add any extra whitespace" $ hedgehog $ do
+      row <- forAll genRow
+      let encoded = encode row
+      annotateShow encoded
+      assert (not (" " `B.isSuffixOf` encoded))
+      assert (not (" " `B.isPrefixOf` encoded))
+  describe "Handling files" $ do
+    it "roundtrips file contents" $ hedgehog $ do
+      rows <- forAll (Gen.list (Range.linear 0 100) genRow)
+      got <- runConduit (traverse_ yield rows .| encodeFile .| decodeFile .| Conduit.sinkList )
+      rows === got