commit 23f34e71aff4fbecc7e1bc1439e5ac6e543da6e9 Author: Mats Rauhala Date: Thu Aug 18 19:19:59 2022 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..fd7f48a --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +.direnv/ +.envrc +dist-newstyle/ + +*.timeclock diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..0ca9ca2 --- /dev/null +++ b/.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'. + # + # - : 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. diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..109115a --- /dev/null +++ b/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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..e59e30f --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified MyLib (someFunc) + +main :: IO () +main = MyLib.someFunc diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..3470816 --- /dev/null +++ b/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"; +} diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..55d0e87 --- /dev/null +++ b/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 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..059a584 --- /dev/null +++ b/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 + ]; + }; + } + ); +} diff --git a/hledger-time.cabal b/hledger-time.cabal new file mode 100644 index 0000000..d4dc3f4 --- /dev/null +++ b/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 diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 index 0000000..6e862d5 --- /dev/null +++ b/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 diff --git a/src/Hledger/Row.hs b/src/Hledger/Row.hs new file mode 100644 index 0000000..5707b78 --- /dev/null +++ b/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 diff --git a/src/MyLib.hs b/src/MyLib.hs new file mode 100644 index 0000000..a600476 --- /dev/null +++ b/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) + diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs new file mode 100644 index 0000000..126cfb7 --- /dev/null +++ b/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 diff --git a/test/Test/Hledger/Row.hs b/test/Test/Hledger/Row.hs new file mode 100644 index 0000000..d210085 --- /dev/null +++ b/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