packages feed

gitrev-typed (empty) → 0.1

raw patch · 22 files changed

+4242/−0 lines, 22 filesdep +basedep +directorydep +env-guard

Dependencies added: base, directory, env-guard, exceptions, file-io, filepath, gitrev-typed, os-string, process, tasty, tasty-hunit, template-haskell, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Revision history for gitrev-typed++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++Note that the first version, `0.1`, is relative to its parent from which it was+forked: https://github.com/acfoltzer/gitrev++## [0.1] -- 2025-05-07+### Changed+* Updated GHC support to `>= 9 && < 9.13`.++### Added+* Added `Development.GitRev.Typed` for typed TH interface.+* Added `Development.GitRev.Typed.OsString` for `OsString` support.+* Added variants that return typed errors (`Either`), rather than just a+  default string "UNKNOWN".+* Added support for obtaining data via environment variables for e.g.+  "out-of-tree" builds.+* New git queries: short hash, git diff, git tree.+* Added support for user-defined custom git queries.++### Fixed+* Possibly fixed locale bug by switching from prelude+  `readFile :: FilePath -> IO String` to+  `file-io.readFile' :: OsPath -> IO ByteString` and decoding to UTF-8.++[0.1]: https://github.com/tbidne/gitrev-typed/releases/tag/0.1
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015-2025 Adam C. Foltzer, 2025-present Thomas Bidne+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of gitrev nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,186 @@+<div align="center">++# Gitrev-typed++## Embedding git metadata in haskell projects++[![Hackage](https://img.shields.io/hackage/v/gitrev-typed)](https://hackage.haskell.org/package/gitrev-typed)+![haskell](https://img.shields.io/static/v1?label=&message=9.0%20-%209.12&logo=haskell&logoColor=655889&labelColor=2f353e&color=655889)+[![ci](http://img.shields.io/github/actions/workflow/status/tbidne/gitrev-typed/ci.yaml?branch=main)](https://github.com/tbidne/gitrev-typed/actions/workflows/ci.yaml)+[![BSD-3-Clause](https://img.shields.io/github/license/tbidne/gitrev-typed?color=blue)](https://opensource.org/licenses/BSD-3-Clause)++</div>++---+++# Index+- [Description](#description)+  - [1. Development.GitRev](#1-developmentgitrev)+  - [2. Development.GitRev.Typed](#2-developmentgitrevtyped)+    - [Out-of-tree builds](#out-of-tree-builds)+  - [3. Development.GitRev.Typed.OsString](#3-developmentgitrevtypedosstring)+- [Library Comparisons](#library-comparisons)+  - [Gitrev](#gitrev)+  - [Githash](#githash)++# Description++This is a fork of the popular [`gitrev`](https://hackage.haskell.org/package/gitrev) package, offering Template Haskell splices for git revision information.++There are three interfaces:++## 1. `Development.GitRev`++This module provides the same interface as `gitrev`'s `Development.GitRev` i.e. untyped splices:++```haskell+-- Definition in Development.GitRev+gitHash :: ExpQ+```++```haskell+{-# LANGUAGE TemplateHaskell #-}++import Development.GitRev qualified as GR++-- Returns a hash like "e67e943dd03744d3f93c21f84e127744e6a04543" or+-- "UNKNOWN", if something goes wrong.+myHash :: String+myHash = $(GR.gitHash)+```++## 2. `Development.GitRev.Typed`++This module -- on the other hand -- provides typed splices e.g.++```haskell+-- Definition in Development.GitRev.Typed+gitHash :: Code Q String+```++```haskell+{-# LANGUAGE TemplateHaskell #-}++import Development.GitRev.Typed qualified as GRT++-- Returns a hash like "e67e943dd03744d3f93c21f84e127744e6a04543" or+-- "UNKNOWN", if something goes wrong.+myHash :: String+myHash = $$(GRT.gitHash)+```++We also provide combinators for defining custom behavior. For instance, we can instead define a variant that fails at compile-time instead of returning the string `UNKNOWN`.++```haskell+-- gitHashQ :: Q (Either GitError String)+-- projectError :: Q (Either e String) -> Q String+-- qToCode :: Q a -> Code Q a+myHashOrDie :: String+myHashOrDie = $$(GRT.qToCode $ GRT.projectError GRT.gitHashQ)+```++### Out-of-tree builds++Furthermore, we have workarounds for "out-of-tree" builds:++```haskell+{-# LANGUAGE OverloadedLists #-}++myHashEnv :: Code Q String+myHashEnv = toCode gitHash+  where+    toCode :: Q (Either (Exceptions GitRevError) String) -> Code Q String+    toCode = GRT.qToCode . GRT.projectError++    gitHash :: Q (Either (Exceptions GitRevError) String)+    gitHash =+      -- Tries, in order:+      --+      -- 1. Retrieving the git hash, as normal.+      -- 2. Running the git action under the directory pointed to by the+      --    environment variable EXAMPLE_HOME, if it exists.+      -- 3. Looking up environment variable EXAMPLE_HASH, returning the+      --    value if it exists.+      GRT.firstSuccessQ+        [ GRT.embedGitError GRT.gitHashQ,+          GRT.runGitInEnvDirQ "EXAMPLE_HOME" GRT.gitHashQ+          GRT.embedEnvError $ GRT.envValQ "EXAMPLE_HASH",+        ]+```++For example, `myHashEnv` will work for `cabal install` if we include the+environment variable:++```sh+$ export EXAMPLE_HOME=$(pwd); cabal install example+```++This function will also work with nix flakes:++```nix+# flake.nix+let+  compiler = pkgs.haskell.packages."ghc9101";+in+{+  # Using nixpkgs haskell infra i.e. developPackage.+  packages.default = compiler.developPackage {+    name = "example";+    root = ./.;+    returnShellEnv = false;+    modifier =+      drv:+      let+        drv' = pkgs.haskell.lib.addBuildTools drv [+          compiler.cabal-install+          compiler.ghc+          pkgs.git+          pkgs.zlib+        ];+      in+      drv'.overrideAttrs (oldAttrs: {+        EXAMPLE_HASH = "${self.rev or self.dirtyRev}";+      });+  };+};+```++See the `example` in the [repo](https://github.com/tbidne/gitrev-typed/) for example usage, and `Development.GitRev.Typed` for full documentation.++## 3. `Development.GitRev.Typed.OsString`++`Development.GitRev.Typed` for `OsString` rather than `String`.++# Library Comparisons++## Overview++- 🌕: Supported.+- 🌓: Partial support.+- 🌑: Not supported.++| 👇 Feature / Library 👉   | `gitrev-typed` | `gitrev` | `githash` |+|---------------------------|----------------|----------|-----------|+| Maintained                | 🌕             | 🌑       | 🌓        |+| Untyped TH                | 🌕             | 🌕       | 🌑        |+| Typed TH                  | 🌕             | 🌑       | 🌕        |+| Custom git queries        | 🌕             | 🌑       | 🌑        |+| "Out-of-tree" workarounds | 🌕             | 🌑       | 🌑        |+| `OsString` support        | 🌕             | 🌑       | 🌑        |++## Gitrev++- As stated, this is a fork of `gitrev`. While `gitrev` has been admirably stable for many years, it was officially declared unmaintained in January 2024, and the [repo](https://github.com/acfoltzer/gitrev/) was archived.++- Not only is `gitrev-typed` currently maintained, it offers the new, typed interface. Additionally, `gitrev-typed` resolves a number of open `gitrev` issues (see the [changelog](./CHANGELOG.md)).++## Githash++- [`Githash`](https://hackage.haskell.org/package/githash) is another `gitrev` fork, though it takes a different approach. Rather than offering multiple, individual git queries, `githash` returns a single one with all of the (pre-defined) git data at once. The user can then take whatever subset they wish.++  This provides nice ergonomics when you want to run multiple queries at once, though it is arguably wasteful when you just want one or two. It also makes it harder to fit custom user queries into the API.++- Both `githash` and `gitrev-typed` have a typed TH interface (unlike `gitrev`).++- `githash` does not support custom git queries, workarounds for "out-of-tree" builds, or `OsString`.
+ gitrev-typed.cabal view
@@ -0,0 +1,132 @@+cabal-version:      3.0+name:               gitrev-typed+version:            0.1+synopsis:           Compile git revision info into Haskell projects+homepage:           https://github.com/tbidne/gitrev-typed+license:            BSD-3-Clause+license-file:       LICENSE+author:             Adam C. Foltzer, Thomas Bidne+maintainer:         Thomas Bidne <tbidne@protonmail.com>+category:           Development+build-type:         Simple+tested-with:+  GHC ==9.0.2+   || ==9.2.8+   || ==9.4.8+   || ==9.6.6+   || ==9.8.4+   || ==9.10.1+   || ==9.12.1++extra-source-files:+  LICENSE+  README.md++extra-doc-files:    CHANGELOG.md+description:+  This is a fork of the popular+  [gitrev](https://hackage.haskell.org/package/gitrev) package, offering+  Template Haskell splices for git revision information. There are three+  interfaces:++  1. "Development.GitRev": The original @gitrev@ interface i.e. untyped splices.++  2. "Development.GitRev.Typed": Splices for typed TH, along with+  support for customization e.g. typed errors, \"out-of-tree\" workarounds+  via environment variables, and custom git actions.++  3. "Development.GitRev.Typed.OsString": @Development.GitRev.Typed@ for+  @OsString@.++source-repository head+  type:     git+  location: https://github.com/tbidne/gitrev-typed.git++common common-lang+  default-extensions:+    DataKinds+    DeriveFunctor+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DuplicateRecordFields+    ExplicitForAll+    ExplicitNamespaces+    FlexibleInstances+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    NamedFieldPuns+    OverloadedStrings+    ScopedTypeVariables+    TupleSections+    TypeApplications+    TypeOperators++  -- Apparently, cabal.project warnings do not apply to other-modules, hence+  -- copying them here.+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wmissing-deriving-strategies+    -Wmissing-export-lists -Wmissing-exported-signatures+    -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields+    -Wprepositive-qualified-module -Wredundant-constraints+    -Wunused-binds -Wunused-packages -Wunused-type-patterns+    -Wno-unticked-promoted-constructors++  default-language:   Haskell2010++library+  import:          common-lang+  build-depends:+    , base              >=4.15.0.0 && <4.22+    , directory         >=1.3.8.0  && <1.4+    , exceptions        ^>=0.10.4+    , file-io           ^>=0.1.1+    , filepath          >=1.5.0.1  && <1.6+    , os-string         ^>=2.0.0+    , process           >=1.6.13.2 && <1.7+    , template-haskell  >=2.17.0.0 && <2.24+    , text              >=0.1.1    && <2.2++  hs-source-dirs:  src+  exposed-modules:+    Development.GitRev+    Development.GitRev.Typed+    Development.GitRev.Typed.OsString++  other-modules:+    Development.GitRev.Internal.Environment+    Development.GitRev.Internal.Environment.OsString+    Development.GitRev.Internal.Git+    Development.GitRev.Internal.Git.Common+    Development.GitRev.Internal.Git.OsString+    Development.GitRev.Internal.OsString+    Development.GitRev.Internal.QFirst+    Development.GitRev.Internal.Utils+    Development.GitRev.Internal.Utils.Common+    Development.GitRev.Internal.Utils.OsString++test-suite unit+  import:         common-lang+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  other-modules:+    Unit.Development.GitRev+    Unit.Development.GitRev.Typed+    Unit.Development.GitRev.Typed.OsString+    Utils++  build-depends:+    , base+    , env-guard         ^>=0.2+    , gitrev-typed+    , os-string+    , tasty             >=1.1.0.3 && <1.6+    , tasty-hunit       >=0.9     && <0.11+    , template-haskell+    , text++  hs-source-dirs: test/unit+  ghc-options:    -threaded
+ src/Development/GitRev.hs view
@@ -0,0 +1,148 @@+-- |+-- Module      :  $Header$+-- Copyright   :  (c) 2015 Adam C. Foltzer, 2025 Thomas Bidne+-- License     :  BSD3+-- Maintainer  :  tbidne@protonmail.com+--+-- Untyped Template Haskell splices for including git information in your+-- project.+--+-- @since 0.1+module Development.GitRev+  ( gitBranch,+    gitCommitCount,+    gitCommitDate,+    gitDescribe,+    gitDiff,+    gitDirty,+    gitDirtyTracked,+    gitHash,+    gitShortHash,+    gitTree,+  )+where++import Development.GitRev.Internal.Git qualified as Git+import Development.GitRev.Internal.Utils qualified as Utils+import Language.Haskell.TH (ExpQ, Q)+import Language.Haskell.TH.Syntax (Lift (lift))++-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@+-- if not in a git repository. For detached heads, this will just be+-- "HEAD".+--+-- ==== __Examples__+--+-- > λ. $gitBranch+-- > "main"+--+-- @since 0.1+gitBranch :: ExpQ+gitBranch = qToExp $ Utils.projectStringUnknown Git.gitBranchQ++-- | Return the number of commits in the current head.+--+-- ==== __Examples__+--+-- > λ. $gitCommitCount+-- > "47"+--+-- @since 0.1+gitCommitCount :: ExpQ+gitCommitCount = qToExp $ Utils.projectStringUnknown Git.gitCommitCountQ++-- | Return the commit date of the current head.+--+-- ==== __Examples__+--+-- > λ. $gitCommitDate+-- > "Mon Apr 14 22:14:44 2025 +1200"+--+-- @since 0.1+gitCommitDate :: ExpQ+gitCommitDate = qToExp $ Utils.projectStringUnknown Git.gitCommitDateQ++-- | Return the long git description for the current git commit, or+-- @UNKNOWN@ if not in a git repository.+--+-- ==== __Examples__+--+-- > λ. $gitDescribe+-- > "1.2.0-14-g40b5d7b"+--+-- @since 0.1+gitDescribe :: ExpQ+gitDescribe = qToExp $ Utils.projectStringUnknown Git.gitDescribeQ++-- | Return the diff of the working copy with HEAD.+--+-- ==== __Examples__+--+-- > λ. $gitDiff+-- > "diff ..."+--+-- @since 0.1+gitDiff :: ExpQ+gitDiff = qToExp $ Utils.projectStringUnknown Git.gitDiffQ++-- | Return @True@ if there are non-committed files present in the+-- repository.+--+-- ==== __Examples__+--+-- > λ. $gitDirty+-- > False+--+-- @since 0.1+gitDirty :: ExpQ+gitDirty = qToExp $ Utils.projectFalse Git.gitDirtyQ++-- | Return @True@ if there are non-commited changes to tracked files+-- present in the repository.+--+-- ==== __Examples__+--+-- > λ. $gitDirtyTracked+-- > False+--+-- @since 0.1+gitDirtyTracked :: ExpQ+gitDirtyTracked = qToExp $ Utils.projectFalse Git.gitDirtyTrackedQ++-- | Return the hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $gitHash+-- > "e67e943dd03744d3f93c21f84e127744e6a04543"+--+-- @since 0.1+gitHash :: ExpQ+gitHash = qToExp $ Utils.projectStringUnknown Git.gitHashQ++-- | Return the short hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $gitShortHash+-- > "e67e943"+--+-- @since 0.1+gitShortHash :: ExpQ+gitShortHash = qToExp $ Utils.projectStringUnknown Git.gitShortHashQ++-- | Return the hash of the current tree.+--+-- ==== __Examples__+--+-- > λ. $gitTreeQ+-- > "b718a493773568bbf920a4710b5b83bd1762dbb9"+--+-- @since 0.1+gitTree :: ExpQ+gitTree = qToExp $ Utils.projectStringUnknown Git.gitTreeQ++qToExp :: forall a. (Lift a) => Q a -> ExpQ+qToExp = (>>= lift)
+ src/Development/GitRev/Internal/Environment.hs view
@@ -0,0 +1,151 @@+-- | Provides utilities for querying environment variables.+--+-- @since 0.1+module Development.GitRev.Internal.Environment+  ( EnvError (..),+    envValQ,+    runInEnvDirQ,+    withEnvValQ,+  )+where++import Control.Exception (Exception (displayException))+import Control.Monad (join)+import Development.GitRev.Internal.Git.Common qualified as GitC+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (Lift)+import System.Directory.OsPath qualified as Dir+import System.Environment qualified as Env+import System.OsPath qualified as OsPath++-- $setup+-- >>> import Development.GitRev.Typed (qToCode)+-- >>> import Language.Haskell.TH (Q, runIO, runQ)+-- >>> import System.Environment (setEnv)++-- | Performs an environment variable lookup in 'Q'.+--+-- ==== __Examples__+--+-- >>> setEnv "SOME_VAR" "val"+-- >>> $$(qToCode $ envValQ "SOME_VAR")+-- Right "val"+--+-- @since 0.1+envValQ ::+  -- | The environment variable @k@.+  String ->+  -- | The result @v@ or an error.+  Q (Either EnvError String)+envValQ var = withEnvValQ var pure++-- | Runs the given 'Q'-action under the directory @d@ pointed to by the+-- given environment variable.+--+-- ==== __Examples__+--+-- >>> import System.Directory (listDirectory)+-- >>> setEnv "SOME_DIR" "./src"+-- >>> $$(qToCode $ runInEnvDirQ "SOME_DIR" $ runIO (listDirectory "./"))+-- Right ["Development"]+--+-- @since 0.1+runInEnvDirQ ::+  forall a.+  -- | The environment variable @k@ that should point to some directory+  -- @d@.+  String ->+  -- | The 'Q' action @q@.+  Q a ->+  -- | The result of running @q@ in directory @d@.+  Q (Either EnvError a)+runInEnvDirQ var m = fmap join $ withEnvValQ var $ \repoDirFp -> do+  repoDirOs <- OsPath.encodeUtf repoDirFp++  -- Try to change directory+  eCurrDir <- runIO $ GitC.trySync $ do+    currDir <- Dir.getCurrentDirectory+    Dir.setCurrentDirectory repoDirOs+    pure currDir++  let mkErr = Left . MkEnvError var (Just repoDirFp)++  case eCurrDir of+    Left ex -> do+      let rsn = "Could not set directory: " ++ displayException ex+      pure $ mkErr rsn+    Right currDir -> do+      r <- m+      eResult <- runIO $ GitC.trySync $ Dir.setCurrentDirectory currDir+      case eResult of+        Left ex -> do+          let rsn = "Could not restore directory: " ++ displayException ex+          pure $ mkErr rsn+        Right _ -> pure $ Right r++-- | Environment variable lookup failure.+--+-- @since 0.1+data EnvError = MkEnvError+  { -- | The environment variable.+    --+    -- @since 0.1+    var :: String,+    -- | The value of the environment variable, if it exists.+    --+    -- @since 0.1+    value :: Maybe String,+    -- | Text reason for the failure.+    --+    -- @since 0.1+    reason :: String+  }+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception EnvError where+  displayException err =+    mconcat+      [ "Environment error with env variable '",+        var err,+        "', value ",+        valStr,+        ": ",+        reason err+      ]+    where+      valStr = case value err of+        Nothing -> "<none>"+        Just value -> "'" ++ value ++ "'"++-- | Runs a 'Q'-action on the result of an environment variable, if it exists.+--+-- ==== __Examples__+--+-- >>> import System.Directory (listDirectory)+-- >>> setEnv "SOME_DIR" "./src"+-- >>> $$(qToCode $ withEnvValQ "SOME_DIR" (runIO . listDirectory))+-- Right ["Development"]+--+-- @since 0.1+withEnvValQ ::+  forall a.+  -- | The environment variable @k@ to lookup.+  String ->+  -- | Function to run on @k@'s /value/ if @k@ exists.+  (String -> Q a) ->+  Q (Either EnvError a)+withEnvValQ var onEnv = do+  lookupEnvQ var >>= \case+    Nothing -> pure $ Left $ MkEnvError var Nothing "No such var found."+    Just result -> Right <$> onEnv result++lookupEnvQ :: String -> Q (Maybe String)+lookupEnvQ = runIO . Env.lookupEnv
+ src/Development/GitRev/Internal/Environment/OsString.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}++-- | "Development.GitRev.Internal.Environment" for 'OsString'.+--+-- @since 0.1+module Development.GitRev.Internal.Environment.OsString+  ( EnvError (..),+    envValQ,+    runInEnvDirQ,+    withEnvValQ,+  )+where++import Control.Exception (Exception (displayException))+import Control.Monad (join)+import Development.GitRev.Internal.Git.Common qualified as GitC+import Development.GitRev.Internal.OsString qualified as OsStringI+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (Lift)+import System.Directory.OsPath qualified as Dir+import System.OsString (OsString, osstr)+#if MIN_VERSION_process(1, 6, 26)+import System.Process.Environment.OsString qualified as Process+#else+import System.Environment qualified as Env+#endif++-- $setup+-- >>> import Development.GitRev.Typed.OsString (qToCode)+-- >>> import Language.Haskell.TH (Q, runIO, runQ)+-- >>> import System.Environment (setEnv)+-- >>> import System.OsPath (osp)+-- >>> import System.OsString (osstr)++-- | Performs an environment variable lookup in 'Q'.+--+-- ==== __Examples__+--+-- >>> setEnv "SOME_VAR" "val"+-- >>> $$(qToCode $ envValQ [osstr|SOME_VAR|])+-- Right "val"+--+-- @since 0.1+envValQ ::+  -- | The environment variable @k@.+  OsString ->+  -- | The result @v@ or an error.+  Q (Either EnvError OsString)+envValQ var = withEnvValQ var pure++-- | Runs the given 'Q'-action under the directory @d@ pointed to by the+-- given environment variable.+--+-- ==== __Examples__+--+-- >>> import System.Directory.OsPath (listDirectory)+-- >>> setEnv "SOME_DIR" "./src"+-- >>> $$(qToCode $ runInEnvDirQ [osstr|SOME_DIR|] $ runIO (listDirectory [osp|./|]))+-- Right ["Development"]+--+-- @since 0.1+runInEnvDirQ ::+  forall a.+  -- | The environment variable @k@ that should point to some directory+  -- @d@.+  OsString ->+  -- | The 'Q' action @q@.+  Q a ->+  -- | The result of running @q@ in directory @d@.+  Q (Either EnvError a)+runInEnvDirQ var m = fmap join $ withEnvValQ var $ \repoDir -> do+  -- Try to change directory+  eCurrDir <- runIO $ GitC.trySync $ do+    currDir <- Dir.getCurrentDirectory+    Dir.setCurrentDirectory repoDir+    pure currDir++  let mkErr = Left . MkEnvError var (Just repoDir)++  case eCurrDir of+    Left ex -> do+      let rsn =+            [osstr|Could not set directory: |]+              <> OsStringI.encodeLenient (displayException ex)+      pure $ mkErr rsn+    Right currDir -> do+      r <- m+      eResult <- runIO $ GitC.trySync $ Dir.setCurrentDirectory currDir+      case eResult of+        Left ex -> do+          let rsn =+                [osstr|Could not restore directory: |]+                  <> OsStringI.encodeLenient (displayException ex)+          pure $ mkErr rsn+        Right _ -> pure $ Right r++-- | Environment variable lookup failure.+--+-- @since 0.1+data EnvError = MkEnvError+  { -- | The environment variable.+    --+    -- @since 0.1+    var :: OsString,+    -- | The value of the environment variable, if it exists.+    --+    -- @since 0.1+    value :: Maybe OsString,+    -- | Text reason for the failure.+    --+    -- @since 0.1+    reason :: OsString+  }+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception EnvError where+  displayException err =+    mconcat+      [ "Environment error with env variable '",+        OsStringI.decodeLenient $ var err,+        "', value ",+        OsStringI.decodeLenient valStr,+        ": ",+        OsStringI.decodeLenient $ reason err+      ]+    where+      valStr = case value err of+        Nothing -> [osstr|<none>|]+        Just value -> [osstr|'|] <> value <> [osstr|'|]++-- | Runs a 'Q'-action on the result of an environment variable, if it exists.+--+-- ==== __Examples__+--+-- >>> import System.Directory.OsPath (listDirectory)+-- >>> setEnv "SOME_DIR" "./src"+-- >>> $$(qToCode $ withEnvValQ [osstr|SOME_DIR|] (runIO . listDirectory))+-- Right ["Development"]+--+-- @since 0.1+withEnvValQ ::+  forall a.+  -- | The environment variable @k@ to lookup.+  OsString ->+  -- | Function to run on @k@'s /value/ if @k@ exists.+  (OsString -> Q a) ->+  Q (Either EnvError a)+withEnvValQ var onEnv = do+  lookupEnvQ var >>= \case+    Nothing -> pure $ Left $ MkEnvError var Nothing [osstr|No such var found.|]+    Just result -> Right <$> onEnv result++lookupEnvQ :: OsString -> Q (Maybe OsString)+lookupEnvQ = runIO . lookupEnv++lookupEnv :: OsString -> IO (Maybe OsString)+#if MIN_VERSION_process(1, 6, 26)+lookupEnv = Process.getEnv+#else+lookupEnv os = do+  fp <- OsStringI.decodeThrowM os+  r <- Env.lookupEnv fp+  traverse OsStringI.encodeThrowM r+#endif
+ src/Development/GitRev/Internal/Git.hs view
@@ -0,0 +1,244 @@+-- | 'Q' primitives for git actions.+--+-- @since 0.1+module Development.GitRev.Internal.Git+  ( -- * Built-in+    GitError (..),+    gitBranchQ,+    gitCommitCountQ,+    gitCommitDateQ,+    gitDescribeQ,+    gitDiffQ,+    gitDirtyQ,+    gitDirtyTrackedQ,+    gitHashQ,+    gitShortHashQ,+    gitTreeQ,++    -- * Git primitives+    runGitQ,+    runGitPostProcessQ,+    IndexUsed (..),+  )+where++import Control.Exception+  ( Exception (displayException),+  )+import Data.Bifunctor (Bifunctor (first))+import Development.GitRev.Internal.Git.Common+  ( GitProcessArgs+      ( MkGitProcessArgs,+        fromStringTotal,+        gitRootArgs,+        runProcessGit,+        toOsPath,+        toStringTotal+      ),+    IndexUsed (IdxNotUsed, IdxUsed),+  )+import Development.GitRev.Internal.Git.Common qualified as Common+import Development.GitRev.Internal.OsString qualified as OsStringI+import Language.Haskell.TH (Q)+import Language.Haskell.TH.Syntax (Lift)+import System.Process qualified as Process++-- $setup+-- >>> import Development.GitRev.Typed (qToCode)++-- | Returns the current git branch.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitBranchQ)+-- Right ...+--+-- @since 0.1+gitBranchQ :: Q (Either GitError String)+gitBranchQ = runGitQ ["rev-parse", "--abbrev-ref", "HEAD"] IdxNotUsed++-- | Returns the git commit count.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitCommitCountQ)+-- Right ...+--+-- @since 0.1+gitCommitCountQ :: Q (Either GitError String)+gitCommitCountQ = runGitQ ["rev-list", "HEAD", "--count"] IdxNotUsed++-- | Returns the latest git commit date.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitCommitDateQ)+-- Right ...+--+-- @since 0.1+gitCommitDateQ :: Q (Either GitError String)+gitCommitDateQ = runGitQ ["log", "HEAD", "-1", "--format=%cd"] IdxNotUsed++-- | Returns the git description.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDescribeQ)+-- Right ...+--+-- @since 0.1+gitDescribeQ :: Q (Either GitError String)+gitDescribeQ = runGitQ ["describe", "--long", "--always"] IdxNotUsed++-- | Return the diff of the working copy with HEAD.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDiffQ)+-- Right ...+--+-- @since 0.1+gitDiffQ :: Q (Either GitError String)+gitDiffQ = runGitPostProcessQ id ["diff", "HEAD"] IdxNotUsed++-- | Returns the git dirty status.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDirtyQ)+-- Right ...+--+-- @since 0.1+gitDirtyQ :: Q (Either GitError Bool)+gitDirtyQ = fmap Common.nonEmpty <$> runGitQ ["status", "--porcelain"] IdxUsed++-- | Returns the git dirty status, ignoring untracked files.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDirtyTrackedQ)+-- Right ...+--+-- @since 0.1+gitDirtyTrackedQ :: Q (Either GitError Bool)+gitDirtyTrackedQ =+  fmap Common.nonEmpty+    <$> runGitQ ["status", "--porcelain", "--untracked-files=no"] IdxUsed++-- | Returns the latest git hash.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitHashQ)+-- Right ...+--+-- @since 0.1+gitHashQ :: Q (Either GitError String)+gitHashQ = runGitQ ["rev-parse", "HEAD"] IdxNotUsed++-- | Returns the latest git short hash.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitShortHashQ)+-- Right ...+--+-- @since 0.1+gitShortHashQ :: Q (Either GitError String)+gitShortHashQ = runGitQ ["rev-parse", "--short", "HEAD"] IdxNotUsed++-- | Returns the hash of the current tree.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitTreeQ)+-- Right ...+--+-- @since 0.1+gitTreeQ :: Q (Either GitError String)+gitTreeQ = runGitQ ["show", "HEAD", "--format=%T", "--no-patch"] IdxNotUsed++-- | Errors that can be encountered with git.+--+-- @since 0.1+newtype GitError = MkGitError+  { -- | @since 0.1+    reason :: String+  }+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception GitError where+  displayException (MkGitError s) = "Git error: " ++ s++-- | Runs git with the arguments. If 'IdxUsed' is passed, it is tracked for+-- recompilation purposes.+--+-- ==== __Examples__+--+-- >>> :{+--   -- Returns 'YYYY-MM-DD' rather than e.g. gitCommitDateQ's+--   -- 'Fri May 2 13:29:59 2025 +1200'.+--   gitCommitDateShortQ :: Q (Either GitError String)+--   gitCommitDateShortQ = runGitQ ["log", "HEAD", "-1", "--format=%cs"] IdxNotUsed+-- :}+--+-- @since 0.1+runGitQ ::+  -- | Arguments to git.+  [String] ->+  -- | Whether the index is used.+  IndexUsed ->+  Q (Either GitError String)+runGitQ = runGitPostProcessQ tillNewLineStr++-- | Like 'runGitQ', except it applies the given function to the result.+-- Normal 'runGitQ' takes everything up until the first new line or carriage+-- return.+--+-- ==== __Examples__+--+-- >>> :{+--   runGitNoProcessQ :: [String] -> IndexUsed -> Q (Either GitError String)+--   runGitNoProcessQ = runGitPostProcessQ id+-- :}+--+-- @since 0.1+runGitPostProcessQ ::+  -- | Function to run on the result.+  (String -> String) ->+  -- | Arguments to git.+  [String] ->+  -- | Whether the index is used.+  IndexUsed ->+  Q (Either GitError String)+runGitPostProcessQ postProcess args idxUsed =+  first mapGitError+    <$> Common.runGitPostprocess+      gitProcessArgs+      postProcess+      args+      idxUsed++mapGitError :: Common.GitError String -> GitError+mapGitError (Common.MkGitError s) = MkGitError s++gitProcessArgs :: GitProcessArgs String+gitProcessArgs =+  MkGitProcessArgs+    { fromStringTotal = id,+      gitRootArgs = ["rev-parse", "--show-toplevel"],+      runProcessGit = \args -> Process.readProcessWithExitCode "git" args "",+      toOsPath = OsStringI.encodeThrowM,+      toStringTotal = id+    }++tillNewLineStr :: String -> String+tillNewLineStr = takeWhile (\c -> c /= '\n' && c /= '\r')
+ src/Development/GitRev/Internal/Git/Common.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module      :  $Header$+-- Copyright   :  (c) 2015 Adam C. Foltzer, 2025 Thomas Bidne+-- License     :  BSD3+-- Maintainer  :  tbidne@protonmail.com+--+-- Provides utilities for querying git for String' and+-- 'System.OsString.OsString'.+--+-- @since 0.1+module Development.GitRev.Internal.Git.Common+  ( GitError (..),+    IndexUsed (..),+    GitProcessArgs (..),+    runGitPostprocess,++    -- * Misc+    tillNewLineOsPath,+    nonEmpty,+    trySync,+  )+where++import Control.Exception+  ( Exception (displayException, fromException),+    SomeAsyncException (SomeAsyncException),+    SomeException,+    throwIO,+    toException,+    tryJust,+  )+import Control.Monad (unless, (>=>))+import Data.Foldable (traverse_)+import Data.Functor ((<&>))+import Data.Maybe (catMaybes, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TEnc+import Development.GitRev.Internal.OsString qualified as OsStringI+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (Lift, addDependentFile)+import System.Directory.OsPath+  ( doesDirectoryExist,+    doesFileExist,+    findExecutable,+    getCurrentDirectory,+  )+import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import System.File.OsPath qualified as FileIO+import System.OsPath (OsPath, osp, (</>))+import System.OsString qualified as OsString++-- | Parameters for running our git process below. Allows us to parameterize+-- over String and OsString.+data GitProcessArgs str = MkGitProcessArgs+  { -- | Conversion from String. Used in error reporting hence should be+    -- total i.e. lenient encodes, if necessary.+    fromStringTotal :: String -> str,+    -- | Args for acquiring git root i.e. ["rev-parse", "--show-toplevel"].+    gitRootArgs :: [str],+    -- | Runs git with parameter args.+    runProcessGit :: [str] -> IO (ExitCode, str, str),+    -- | Encode p to OsPath. IO due to possibility of failure i.e. we want+    -- errors to throw.+    toOsPath :: str -> IO OsPath,+    -- | Conversion to String. Used in error reporting hence should be+    -- total i.e. lenient encodes, if necessary.+    toStringTotal :: str -> String+  }++-- | Run git with the given arguments and no stdin, returning the+-- stdout output.+runGitPostprocess ::+  forall str.+  GitProcessArgs str ->+  -- | Post-processing on the result.+  (str -> str) ->+  -- | Args to run with git.+  [str] ->+  -- | Whether the index is used.+  IndexUsed ->+  Q (Either (GitError str) str)+runGitPostprocess+  gpArgs@MkGitProcessArgs {runProcessGit, fromStringTotal}+  postProcess+  args+  useIdx = do+    runIO (trySync getFilesAndGitResult) >>= \case+      Left ex -> pure $ Left $ MkGitError (fromStringTotal $ displayException ex)+      Right (filesToTrack, (ec, out, err)) -> do+        -- REVIEW: Do we want to add these even if git fails? Doing it for now+        -- because that was the previous behavior...+        --+        -- Also, note that if addDependentOsPath fails (i.e. a bug), it will+        -- cause everything to fail.+        traverse_ addDependentOsPath filesToTrack+        case ec of+          ExitFailure _ -> pure $ Left $ MkGitError err+          ExitSuccess -> pure $ Right (postProcess out)+    where+      -- Try to do as much IO in here as possible so it is easy to prevent+      -- exceptions from slipping later on by surrounding this with trySync.+      --+      -- This is why we return the list of dependent files to track, rather+      -- than handling them in-place. addDependentFile cannot be called+      -- inside IO, but we want all IO logic in one-place, if possible.+      -- Hence we do all the IO things here, return the files we want to+      -- track, then add them once we are in Q.+      getFilesAndGitResult :: IO ([OsPath], (ExitCode, str, str))+      getFilesAndGitResult = do+        gitFound <- isJust <$> findExecutable [osp|git|]++        unless gitFound $ throwIO GitExeNotFound++        filesToTrack <- getGitFiles++        result <- runProcessGit args+        pure (filesToTrack, result)++      -- Return the files to track later with addDependentFile. We split this+      -- up so that we can stuff all the IO logic behind try, then later use+      -- addDependentFile once we are in Q.+      getGitFiles :: IO [OsPath]+      getGitFiles = do+        -- a lot of bookkeeping to record the right dependencies+        pwd <- getDotGit gpArgs+        let hd = pwd </> [osp|HEAD|]+            index = pwd </> [osp|index|]+            packedRefs = pwd </> [osp|packed-refs|]+        hdExists <- doesFileExist hd+        headAndRefs <- whenList hdExists $ do+          -- the HEAD file either contains the hash of a detached head+          -- or a pointer to the file that contains the hash of the head+          contents <- readFileUtf8 hd+          case T.splitAt 5 contents of+            -- pointer to ref+            ("ref: ", relRef) -> do+              relRefOs <- OsStringI.encodeThrowM $ T.unpack relRef+              let ref = pwd </> tillNewLineOsPath relRefOs+              refExists <- doesFileExist ref+              pure $+                if refExists+                  then [Just hd, Just ref]+                  else [Just hd]+            -- detached head+            _hash -> pure [Just hd]+        -- add the index if it exists to set the dirty flag+        indexExists <- doesFileExist index+        packedExists <- doesFileExist packedRefs+        let mIdxFile = whenJust (indexExists && useIdx == IdxUsed) index+            -- if the refs have been packed, the info we're looking for+            -- might be in that file rather than the one-file-per-ref case+            -- handled above+            mPackedRefFiles = whenJust packedExists packedRefs+        pure (catMaybes $ mIdxFile : mPackedRefFiles : headAndRefs)++-- | @since 0.1+tillNewLineOsPath :: OsPath -> OsPath+tillNewLineOsPath = OsString.takeWhile (\c -> c /= nl && c /= cr)+  where+    nl = OsString.unsafeFromChar '\n'+    cr = OsString.unsafeFromChar '\r'++-- | Determine where our @.git@ directory is, in case we're in a+-- submodule.+getDotGit :: forall str. GitProcessArgs str -> IO OsPath+getDotGit gpArgs = do+  pwd <- getGitRoot gpArgs+  let dotGit = pwd </> [osp|.git|]+  isDir <- doesDirectoryExist dotGit++  if isDir+    then pure dotGit+    else do+      isFile <- doesFileExist dotGit++      unless isFile $ throwIO $ DotGitNotFound dotGit++      contents <- readFileUtf8 dotGit+      case T.splitAt 8 contents of+        ("gitdir: ", relDir) -> do+          relDirOs <- OsStringI.encodeThrowM $ T.unpack relDir+          isRelDir <- doesDirectoryExist relDirOs+          if isRelDir+            then pure relDirOs+            else throwIO $ DotGitFileNotDir dotGit relDirOs+        _ -> throwIO $ DotGitFileBadPrefix dotGit contents++readFileUtf8 :: OsPath -> IO Text+readFileUtf8 = FileIO.readFile' >=> either throwIO pure . TEnc.decodeUtf8'++-- | Get the root directory of the Git repo.+getGitRoot :: forall str. GitProcessArgs str -> IO OsPath+getGitRoot+  MkGitProcessArgs+    { gitRootArgs,+      toOsPath,+      toStringTotal,+      runProcessGit+    } = do+    (code, out, _) <- runProcessGit gitRootArgs+    case code of+      ExitSuccess -> tillNewLineOsPath <$> toOsPath out+      ExitFailure _ -> do+        mCwd <-+          trySync getCurrentDirectory <&> \case+            Left _ -> Nothing+            Right cwd -> Just cwd+        throwIO $ GitRootNotFound mCwd (toStringTotal <$> gitRootArgs)++-- | Like when, except returns the empty list rather than unit. Monomorphic+-- on list (rather than e.g. Monoid) for clarity.+whenList :: forall f a. (Applicative f) => Bool -> f [a] -> f [a]+whenList False _ = pure []+whenList True xs = xs++-- | Similar to when, excepts lifts the param to Maybe. Monomorphic+-- on Maybe (rather than e.g. Alternative) for clarity.+whenJust :: forall a. Bool -> a -> Maybe a+whenJust False _ = Nothing+whenJust True x = Just x++nonEmpty :: forall a. (Eq a, Monoid a) => a -> Bool+nonEmpty = (/= mempty)++-- | Type to flag if the git index is used or not in a call to @runGitQ@.+--+-- @since 0.1+data IndexUsed+  = -- | The git index is used.+    --+    -- @since 0.1+    IdxUsed+  | -- | The git index is /not/ used.+    --+    -- @since 0.1+    IdxNotUsed+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Show+    )++-- | Errors that can be encountered with git. The argument is a string-like+-- message.+--+-- @since 0.1+newtype GitError str = MkGitError str+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | Internal error. If this is thrown, it will be turned into its string+-- representation then wrapped in GitError. This exists entirely to improve+-- error messages / make some code here clearer.+data InternalError+  = -- | .git file started with unexpected prefix.+    DotGitFileBadPrefix OsPath Text+  | -- | directory pointed to by .git file was not found.+    DotGitFileNotDir OsPath OsPath+  | -- | .git dir/file not found.+    DotGitNotFound OsPath+  | -- | Git exe not found.+    GitExeNotFound+  | -- | Git root not found.+    GitRootNotFound (Maybe OsPath) [String]+  deriving stock (Show)++instance Exception InternalError where+  displayException = \case+    DotGitFileBadPrefix dotGit txt ->+      T.unpack . mconcat $+        [ "Expected .git file '",+          T.pack $ OsStringI.decodeLenient dotGit,+          "' to start with prefix 'gitdir: ', received: '",+          txt,+          "'"+        ]+    DotGitFileNotDir dotGit path ->+      mconcat+        [ "Directory listed in .git file '",+          OsStringI.decodeLenient dotGit,+          "' does not exist: '",+          OsStringI.decodeLenient path,+          "'"+        ]+    DotGitNotFound dotGit ->+      mconcat+        [ "File or directory does not exist: '",+          OsStringI.decodeLenient dotGit,+          "'"+        ]+    GitExeNotFound -> "Git exe not found"+    GitRootNotFound mCurrDir args ->+      mconcat+        [ "Failed running git with args: ",+          show args,+          ", when trying to find git root",+          currDirTxt+        ]+      where+        currDirTxt = case mCurrDir of+          Nothing -> "."+          Just cwd ->+            mconcat+              [ " in directory '",+                OsStringI.decodeLenient cwd,+                "'"+              ]++trySync :: forall a. IO a -> IO (Either SomeException a)+trySync = tryIf isSyncException++tryIf :: forall e a. (Exception e) => (e -> Bool) -> IO a -> IO (Either e a)+tryIf p = tryJust (\e -> if p e then Just e else Nothing)++isSyncException :: forall e. (Exception e) => e -> Bool+isSyncException e = case fromException (toException e) of+  Just SomeAsyncException {} -> False+  Nothing -> True++addDependentOsPath :: OsPath -> Q ()+addDependentOsPath = OsStringI.decodeThrowM >=> addDependentFile
+ src/Development/GitRev/Internal/Git/OsString.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE QuasiQuotes #-}++-- | "Development.GitRev.Internal.Git" for 'OsString'.+--+-- @since 0.1+module Development.GitRev.Internal.Git.OsString+  ( -- * Built-in+    GitError (..),+    gitBranchQ,+    gitCommitCountQ,+    gitCommitDateQ,+    gitDescribeQ,+    gitDiffQ,+    gitDirtyQ,+    gitDirtyTrackedQ,+    gitHashQ,+    gitShortHashQ,+    gitTreeQ,++    -- * Git primitives+    runGitQ,+    runGitPostProcessQ,+    IndexUsed (..),+  )+where++import Control.Exception (Exception (displayException))+import Data.Bifunctor (Bifunctor (first))+import Development.GitRev.Internal.Git.Common+  ( GitProcessArgs+      ( MkGitProcessArgs,+        fromStringTotal,+        gitRootArgs,+        runProcessGit,+        toOsPath,+        toStringTotal+      ),+    IndexUsed (IdxNotUsed, IdxUsed),+  )+import Development.GitRev.Internal.Git.Common qualified as Common+import Development.GitRev.Internal.OsString qualified as OsStringI+import Language.Haskell.TH (Q)+import Language.Haskell.TH.Syntax (Lift)+import System.OsString (OsString, osstr)+import System.Process qualified as Process++-- $setup+-- >>> :set -XQuasiQuotes+-- >>> import Development.GitRev.Typed.OsString (qToCode)++-- | Returns the current git branch.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitBranchQ)+-- Right ...+--+-- @since 0.1+gitBranchQ :: Q (Either GitError OsString)+gitBranchQ =+  runGitQ [[osstr|rev-parse|], [osstr|--abbrev-ref|], [osstr|HEAD|]] IdxNotUsed++-- | Returns the git commit count.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitCommitCountQ)+-- Right ...+--+-- @since 0.1+gitCommitCountQ :: Q (Either GitError OsString)+gitCommitCountQ =+  runGitQ [[osstr|rev-list|], [osstr|HEAD|], [osstr|--count|]] IdxNotUsed++-- | Returns the latest git commit date.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitCommitDateQ)+-- Right ...+--+-- @since 0.1+gitCommitDateQ :: Q (Either GitError OsString)+gitCommitDateQ =+  runGitQ+    [ [osstr|log|],+      [osstr|HEAD|],+      [osstr|-1|],+      [osstr|--format=%cd|]+    ]+    IdxNotUsed++-- | Returns the git description.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDescribeQ)+-- Right ...+--+-- @since 0.1+gitDescribeQ :: Q (Either GitError OsString)+gitDescribeQ =+  runGitQ [[osstr|describe|], [osstr|--long|], [osstr|--always|]] IdxNotUsed++-- | Return the diff of the working copy with HEAD.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDiffQ)+-- Right ...+--+-- @since 0.1+gitDiffQ :: Q (Either GitError OsString)+gitDiffQ = runGitPostProcessQ id [[osstr|diff|], [osstr|HEAD|]] IdxNotUsed++-- | Returns the git dirty status.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDirtyQ)+-- Right ...+--+-- @since 0.1+gitDirtyQ :: Q (Either GitError Bool)+gitDirtyQ =+  fmap Common.nonEmpty+    <$> runGitQ [[osstr|status|], [osstr|--porcelain|]] IdxUsed++-- | Returns the git dirty status, ignoring untracked files.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitDirtyTrackedQ)+-- Right ...+--+-- @since 0.1+gitDirtyTrackedQ :: Q (Either GitError Bool)+gitDirtyTrackedQ =+  fmap Common.nonEmpty+    <$> runGitQ+      [[osstr|status|], [osstr|--porcelain|], [osstr|--untracked-files=no|]]+      IdxUsed++-- | Returns the latest git hash.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitHashQ)+-- Right ...+--+-- @since 0.1+gitHashQ :: Q (Either GitError OsString)+gitHashQ = runGitQ [[osstr|rev-parse|], [osstr|HEAD|]] IdxNotUsed++-- | Returns the latest git short hash.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitShortHashQ)+-- Right ...+--+-- @since 0.1+gitShortHashQ :: Q (Either GitError OsString)+gitShortHashQ =+  runGitQ [[osstr|rev-parse|], [osstr|--short|], [osstr|HEAD|]] IdxNotUsed++-- | Returns the hash of the current tree.+--+-- ==== __Examples__+--+-- >>> $$(qToCode gitTreeQ)+-- Right ...+--+-- @since 0.1+gitTreeQ :: Q (Either GitError OsString)+gitTreeQ =+  runGitQ+    [ [osstr|show|],+      [osstr|HEAD|],+      [osstr|--format=%T|],+      [osstr|--no-patch|]+    ]+    IdxNotUsed++-- | Errors that can be encountered with git.+--+-- @since 0.1+newtype GitError = MkGitError+  { -- | @since 0.1+    reason :: OsString+  }+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception GitError where+  displayException (MkGitError s) = "Git error: " ++ OsStringI.decodeLenient s++-- | Runs git with the arguments. If 'IdxUsed' is passed, it is tracked for+-- recompilation purposes.+--+-- ==== __Examples__+--+-- >>> :{+--   -- Returns 'YYYY-MM-DD' rather than e.g. gitCommitDateQ's+--   -- 'Fri May 2 13:29:59 2025 +1200'.+--   gitCommitDateShortQ :: Q (Either GitError OsString)+--   gitCommitDateShortQ =+--     runGitQ+--       [[osstr|log|], [osstr|HEAD|], [osstr|-1|], [osstr|--format=%cs|]]+--       IdxNotUsed+-- :}+--+-- @since 0.1+runGitQ ::+  -- | Arguments to git.+  [OsString] ->+  -- | Whether the index is used.+  IndexUsed ->+  Q (Either GitError OsString)+runGitQ = runGitPostProcessQ Common.tillNewLineOsPath++-- | Like 'runGitQ', except it applies the given function to the result.+-- Normal 'runGitQ' takes everything up until the first new line or carriage+-- return.+--+-- ==== __Examples__+--+-- >>> :{+--   runGitNoProcessQ :: [OsString] -> IndexUsed -> Q (Either GitError OsString)+--   runGitNoProcessQ = runGitPostProcessQ id+-- :}+--+-- @since 0.1+runGitPostProcessQ ::+  -- | Function to run on the result.+  (OsString -> OsString) ->+  -- | Arguments to git.+  [OsString] ->+  -- | Whether the index is used.+  IndexUsed ->+  Q (Either GitError OsString)+runGitPostProcessQ postProcess args idxUsed =+  first mapGitError+    <$> Common.runGitPostprocess+      gitProcessArgs+      postProcess+      args+      idxUsed++mapGitError :: Common.GitError OsString -> GitError+mapGitError (Common.MkGitError s) = MkGitError s++gitProcessArgs :: GitProcessArgs OsString+gitProcessArgs =+  MkGitProcessArgs+    { fromStringTotal = OsStringI.encodeLenient,+      gitRootArgs = [[osstr|rev-parse|], [osstr|--show-toplevel|]],+      -- TODO: Once process gets OsString support, replace+      -- readProcessWithExitCode below. Should make all of this encoding+      -- unnecessary.+      runProcessGit = \args -> do+        args' <- traverse OsStringI.decodeThrowM args+        (ec, out, err) <- Process.readProcessWithExitCode "git" args' ""+        (ec,,OsStringI.encodeLenient err) <$> OsStringI.encodeThrowM out,+      toOsPath = pure,+      toStringTotal = OsStringI.decodeLenient+    }
+ src/Development/GitRev/Internal/OsString.hs view
@@ -0,0 +1,82 @@+-- | Internal OsString utilities. Exists primarily to provide lenient+-- encodings (for error reporting).+--+-- @since 0.1+module Development.GitRev.Internal.OsString+  ( -- * Encoding++    -- ** Total+    encodeLenient,++    -- ** Partial+    encodeThrowM,++    -- * Decoding++    -- ** Total+    decodeLenient,++    -- ** Partial+    decodeThrowM,+  )+where++import Control.Monad.Catch (MonadThrow)+import GHC.IO.Encoding.Failure (CodingFailureMode (TransliterateCodingFailure))+import GHC.IO.Encoding.Latin1 qualified as Latin1+import System.IO (TextEncoding)+import System.OsPath.Encoding (EncodingException)+import System.OsString (OsString)+import System.OsString qualified as OsString+import System.OsString.Encoding qualified as Enc++-- | Partial decoding. Throws 'EncodingException'.+--+-- @since 0.1+decodeThrowM :: forall m. (MonadThrow m) => OsString -> m FilePath+decodeThrowM = OsString.decodeUtf++-- | Partial encoding. Throws 'EncodingException'.+--+-- @since 0.1+encodeThrowM :: forall m. (MonadThrow m) => FilePath -> m OsString+encodeThrowM = OsString.encodeUtf++-- | Total decoding, replacing errors with the closest visual match.+-- Latin1 on posix, Ucs2le on windows. This is intended for situations where+-- distortion is preferable to a crash e.g. error rendering.+--+-- @since 0.1+decodeLenient :: OsString -> FilePath+decodeLenient = elimEx . OsString.decodeWith posixEncoding windowsEncoding+  where+    (posixEncoding, windowsEncoding, elimEx) = encodingsLenient++-- | Total encoding, replacing errors with the closest visual match.+-- Latin1 on posix, Ucs2le on windows. This is intended for situations where+-- distortion is preferable to a crash e.g. error rendering.+--+-- @since 0.1+encodeLenient :: FilePath -> OsString+encodeLenient = elimEx . OsString.encodeWith posixEncoding windowsEncoding+  where+    (posixEncoding, windowsEncoding, elimEx) = encodingsLenient++-- Total encodings.+encodingsLenient ::+  forall a.+  ( TextEncoding,+    TextEncoding,+    Either EncodingException a -> a+  )+encodingsLenient =+  ( -- While these __shouldn't__ fail, hence TransliterateCodingFailure is+    -- unnecessary, I'm less sure about ucs2le. Since we really want these to+    -- be total (garbage decodes are regrettable, but we can live with it),+    -- I see no reason not to use TransliterateCodingFailure, out of paranoia.+    Latin1.mkLatin1 TransliterateCodingFailure,+    Enc.mkUcs2le TransliterateCodingFailure,+    elimEx+  )+  where+    elimEx = either (error . show) id
+ src/Development/GitRev/Internal/QFirst.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP #-}++-- | Provides 'QFirst' type.+--+-- @since 0.1+module Development.GitRev.Internal.QFirst+  ( -- * Combining Q actions lazily+    QFirst (..),+    mkQFirst,+    unQFirst,+    firstSuccessQ,+    Errors (..),+    mkErrors,+    unErrors,+  )+where++import Control.Exception (Exception (displayException), SomeException)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Bifunctor (Bifunctor (bimap, first, second))+#if MIN_VERSION_base(4, 18, 0)+import Data.Foldable1 (Foldable1 (foldMap1))+#endif+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TLB+import Data.Text.Lazy.Builder.Int qualified as TLBI+import Development.GitRev.Internal.Git.Common qualified as Common+import GHC.Records (HasField (getField))+import Language.Haskell.TH (Q)+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Development.GitRev.Typed (qToCode)+-- >>> import Development.GitRev.Internal.Git (GitError (..), gitDirtyQ, gitHashQ)+-- >>> import Development.GitRev.Internal.Environment (EnvError (..))+-- >>> import Language.Haskell.TH (Q, runIO, runQ)+-- >>> import System.Environment (setEnv)++-- | Collects multiple errors. Intended for displaying multiple+-- exceptions via 'displayException'.+--+-- @since 0.1+newtype Errors e = MkErrors (NonEmpty e)+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Foldable,+      -- | @since 0.1+      Functor,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show,+      -- | @since 0.1+      Traversable+    )+  deriving newtype+    ( -- | @since 0.1+      Applicative,+      -- | @since 0.1+      Monad,+      -- | @since 0.1+      Semigroup+    )++-- | @since 0.1+instance HasField "unErrors" (Errors e) (NonEmpty e) where+  getField = unErrors++-- | @since 0.1+instance (Exception e) => Exception (Errors e) where+  displayException (MkErrors errs) =+    mconcat+      [ "Exception(s):",+        renderErrs errs+      ]+    where+      renderErrs =+        T.unpack+          . TL.toStrict+          . TLB.toLazyText+          . foldMap renderErr+          . NE.zip @Int (1 :| [2 ..])++      renderErr (idx, e) =+        (\b -> "\n" <> TLBI.decimal idx <> ". " <> b)+          . TLB.fromText+          . T.strip+          . T.pack+          . displayException+          $ e++-- | Unwraps 'Errors'.+--+-- @since 0.1+unErrors :: forall e. Errors e -> NonEmpty e+unErrors (MkErrors e) = e++-- | Wraps a type in 'Errors'.+--+-- @since 0.1+mkErrors :: forall e. NonEmpty e -> Errors e+mkErrors = MkErrors++-- | Wrapper for 'Q' over 'Either' with a lazier 'Semigroup'. With this, we+-- can run:+--+-- @+--   mkQFirst q1 <> mkQFirst q2+-- @+--+-- This will only execute @q2@ if @q1@ returns 'Left', unlike 'Q'\'s normal+-- 'Semigroup' instance.+--+-- If both actions fail, then both errors will be returned via 'Errors'.+--+-- === Warning: exceptions+--+-- In order for 'QFirst' to work as expected, the underlying 'Q' action+-- should /not/ throw exceptions. Uncaught exceptions will not be caught+-- by 'QFirst', hence the intended "try multiple 'Q'-actions until we have a+-- success" pattern will not work.+--+-- @since 0.1+newtype QFirst e a = MkQFirst (Q (Either (Errors e) a))+  deriving stock+    ( -- | @since 0.1+      Functor+    )++-- | @since 0.1+instance HasField "unQFirst" (QFirst e a) (Q (Either (Errors e) a)) where+  getField = unQFirst++-- | @since 0.1+instance Semigroup (QFirst e a) where+  MkQFirst q1 <> q2 =+    MkQFirst $+      q1 >>= \case+        Right x -> pure $ Right x+        Left errs -> first (errs <>) <$> unQFirst q2++-- | @since 0.1+instance Applicative (QFirst e) where+  pure = mkQFirst . pure . Right++  MkQFirst q1 <*> q2 =+    MkQFirst $+      q1 >>= \case+        Left errs -> pure $ Left errs+        Right f -> second f <$> unQFirst q2++-- | @since 0.1+instance Monad (QFirst e) where+  MkQFirst q1 >>= k =+    MkQFirst $+      q1 >>= \case+        Left errs -> pure $ Left errs+        Right x -> unQFirst $ k x++-- | Catches synchronous exceptions.+--+-- @since 0.1+instance (e ~ SomeException) => MonadIO (QFirst e) where+  liftIO = MkQFirst . liftIO . fmap (first mapError) . Common.trySync+    where+      mapError = MkErrors . (:| [])++-- | @since 0.1+instance Bifunctor QFirst where+  bimap f g (MkQFirst q) = MkQFirst $ fmap (bimap (fmap f) g) q++-- | Unwraps 'QFirst'.+--+-- @since 0.1+unQFirst :: forall e a. QFirst e a -> Q (Either (Errors e) a)+unQFirst (MkQFirst q) = q++-- | Wraps a 'Q' computation in 'QFirst'.+--+-- @since 0.1+mkQFirst :: forall e a. Q (Either e a) -> QFirst e a+mkQFirst = MkQFirst . fmap (first (mkErrors . NE.singleton))++-- | @firstSuccessQ qs@ takes the first @qi@ in @qs@ that returns+-- 'Right', without executing any @qj@ for @j > i@. If there are no+-- 'Right's, returns all errors.+--+-- ==== __Examples__+--+-- >>> :{+--    $$( qToCode $+--          firstSuccessQ $+--            (pure $ Left $ MkGitError "not found")+--              :| [ gitHashQ,+--                   error "oh no"+--                 ]+--      )+-- :}+-- Right ...+--+-- @since 0.1+firstSuccessQ ::+  forall e a.+  NonEmpty (Q (Either e a)) -> Q (Either (Errors e) a)+firstSuccessQ = unQFirst . foldMap1 mkQFirst++#if !MIN_VERSION_base(4, 18, 0)+-- Copied from base. Technically not the same as the import above since+-- that one works for all Foldable1, not just NonEmpty, but we only use it+-- here for NonEmpty, so whatever.+foldMap1 :: forall a m. (Semigroup m) => (a -> m) -> NonEmpty a -> m+foldMap1 f (x :| xs) = go (f x) xs+  where+    go y [] = y+    go y (z : zs) = y <> go (f z) zs+#endif
+ src/Development/GitRev/Internal/Utils.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE QuantifiedConstraints #-}++-- | Utils module.+--+-- @since 0.1+module Development.GitRev.Internal.Utils+  ( -- * Either projections+    projectStringUnknown,+    Common.projectConst,+    Common.projectFalse,+    Common.projectError,+    Common.projectErrorMap,+    Common.projectLeft,++    -- * Composing errors+    GitRevError (..),++    -- ** Functions+    runGitInEnvDirQ,++    -- ** Mapping utilities+    embedGitError,+    embedEnvError,+    embedTextError,+    Common.joinFirst,+  )+where++import Control.Exception (Exception (displayException))+import Data.Bifunctor (Bifunctor (first))+import Data.Text (Text)+import Data.Text qualified as T+import Development.GitRev.Internal.Environment (EnvError)+import Development.GitRev.Internal.Environment qualified as Env+import Development.GitRev.Internal.Git (GitError)+import Development.GitRev.Internal.Utils.Common qualified as Common+import Language.Haskell.TH (Q)+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Development.GitRev.Typed (qToCode)+-- >>> import Development.GitRev.Internal.Git (GitError (..), gitDirtyQ, gitHashQ)+-- >>> import Development.GitRev.Internal.Environment (EnvError (..))+-- >>> import Language.Haskell.TH (Q, runIO, runQ)+-- >>> import System.Environment (setEnv)++-- | Projects 'Left' to the string @UNKNOWN@.+--+-- ==== __Examples__+--+-- >>> $$(qToCode $ projectStringUnknown (pure $ Left ()))+-- "UNKNOWN"+--+-- @since 0.1+projectStringUnknown ::+  forall f e.+  (Functor f) =>+  f (Either e String) ->+  f String+projectStringUnknown = Common.projectConst "UNKNOWN"++-- | General error type for anything that can go wrong when running+-- @gitrev-typed@ splices.+--+-- @since 0.1+data GitRevError+  = -- | Git error.+    --+    -- @since 0.1+    GitRevErrorGit GitError+  | -- | Environment variable lookup error.+    --+    -- @since 0.1+    GitRevErrorEnv EnvError+  | -- | Catch-all for anything else that can go wrong.+    --+    -- @since 0.1+    GitRevErrorText Text+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception GitRevError where+  displayException (GitRevErrorGit ge) = displayException ge+  displayException (GitRevErrorEnv x) = displayException x+  displayException (GitRevErrorText txt) = T.unpack txt++-- | Runs the git action under the directory @d@ pointed to by the+-- given environment variable.+--+-- ==== __Examples__+--+-- >>> setEnv "SOME_DIR" "./"+-- >>> $$(qToCode $ runGitInEnvDirQ "SOME_DIR" gitHashQ)+-- Right ...+--+-- @since 0.1+runGitInEnvDirQ ::+  forall a.+  -- | Environment variable pointing to a directory path, in which we run+  -- the git process.+  String ->+  -- | Git process to run.+  Q (Either GitError a) ->+  -- | The result.+  Q (Either GitRevError a)+runGitInEnvDirQ var =+  fmap (Common.joinFirst GitRevErrorEnv GitRevErrorGit)+    . Env.runInEnvDirQ var++-- | Embeds a 'GitError' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either GitError ())+--       q = pure (Left $ MkGitError "not found")+--   in runQ $ embedGitError q+-- :}+-- Left (GitRevErrorGit (MkGitError {reason = "not found"}))+--+-- @since 0.1+embedGitError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p GitError a) ->+  f (p GitRevError a)+embedGitError = fmap (first GitRevErrorGit)++-- | Embeds an 'EnvError' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either EnvError ())+--       q = pure (Left $ MkEnvError "VAR" Nothing "VAR does not exist")+--   in runQ $ embedEnvError q+-- :}+-- Left (GitRevErrorEnv (MkEnvError {var = "VAR", value = Nothing, reason = "VAR does not exist"}))+--+-- @since 0.1+embedEnvError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p EnvError a) ->+  f (p GitRevError a)+embedEnvError = fmap (first GitRevErrorEnv)++-- | Embeds a 'Text' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either Text ())+--       q = pure (Left "Something went wrong")+--   in runQ $ embedTextError q+-- :}+-- Left (GitRevErrorText "Something went wrong")+--+-- @since 0.1+embedTextError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p Text a) ->+  f (p GitRevError a)+embedTextError = fmap (first GitRevErrorText)
+ src/Development/GitRev/Internal/Utils/Common.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE QuantifiedConstraints #-}++-- | Common functionality for "Development.GitRev.Internal.Utils".+--+-- @since 0.1+module Development.GitRev.Internal.Utils.Common+  ( -- * Either projections+    projectConst,+    projectFalse,+    projectError,+    projectErrorMap,+    projectLeft,++    -- * Bifunctor utils+    joinFirst,+  )+where++import Control.Exception (Exception (displayException))+import Control.Monad (join)+import Data.Bifunctor (Bifunctor (bimap, first))++-- $setup+-- >>> import Data.Text (Text)+-- >>> import Development.GitRev.Typed.OsString (qToCode)+-- >>> import Development.GitRev.Internal.Environment (EnvError (..))+-- >>> import Development.GitRev.Internal.Git (gitDirtyQ)+-- >>> import Development.GitRev.Internal.Utils (GitRevError (..))+-- >>> import Language.Haskell.TH (Q)++-- | Projects 'Left' to the given value.+--+-- ==== __Examples__+--+-- >>> $$(qToCode $ projectConst "FAILURE" (pure $ Left ()))+-- "FAILURE"+--+-- @since 0.1+projectConst ::+  forall f e a.+  (Functor f) =>+  a ->+  f (Either e a) ->+  f a+projectConst = projectLeft . const++-- | Projects 'Left' to 'False'.+--+-- ==== __Examples__+--+--+-- >>> $$(qToCode $ projectFalse (pure $ Left ()))+-- False+--+-- @since 0.1+projectFalse :: forall f e. (Functor f) => f (Either e Bool) -> f Bool+projectFalse = projectLeft (const False)++-- | Projects 'Left' via 'error', rendering via 'displayException'. Hence+-- an error will cause a compilation failure in 'Language.Haskell.TH.Q'.+--+-- ==== __Examples__+--+-- >>> :{+--   let gitHashOrDieQ :: Q Bool+--       gitHashOrDieQ = projectError gitDirtyQ+-- :}+--+-- @since 0.1+projectError :: forall f e a. (Exception e, Functor f) => f (Either e a) -> f a+projectError = projectErrorMap displayException++-- | Projects 'Left' via 'error', rendering via the given function. Hence+-- an error will cause a compilation failure.+--+-- ==== __Examples__+--+-- >>> :{+--   let gitHashOrDieQ :: Q Bool+--       gitHashOrDieQ = (projectErrorMap show) gitDirtyQ+-- :}+--+-- @since 0.1+projectErrorMap ::+  forall f e a.+  (Functor f) =>+  (e -> String) ->+  f (Either e a) ->+  f a+projectErrorMap onErr = projectLeft (error . onErr)++-- | Projects 'Left' via the given function.+--+-- @since 0.1+projectLeft :: forall f e a. (Functor f) => (e -> a) -> f (Either e a) -> f a+projectLeft f = fmap (either f id)++-- | Join the 'first' component in a bifunctor, useful for unifying+-- nested errors with @GitRevError@.+--+-- ==== __Examples__+--+-- >>> e = Right @EnvError (Left @Text @() "an error")+-- >>> :type e+-- e :: Either EnvError (Either Text ())+--+-- >>> let joined = joinFirst GitRevErrorEnv GitRevErrorText e+-- >>> joined+-- Left (GitRevErrorText "an error")+--+-- >>> :type joined+-- joined :: Either GitRevError ()+--+-- @since 0.1+joinFirst ::+  forall p a1 a2 b c.+  ( Bifunctor p,+    forall a. Monad (p a)+  ) =>+  -- | Map outer.+  (a1 -> b) ->+  -- | Map inner.+  (a2 -> b) ->+  -- | Nested bifunctor.+  p a1 (p a2 c) ->+  -- | Flattened bifunctor.+  p b c+joinFirst embedE1 embedE2 = join . bimap embedE1 (first embedE2)
+ src/Development/GitRev/Internal/Utils/OsString.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Development.GitRev.Internal.Utils for 'OsString'.+--+-- @since 0.1+module Development.GitRev.Internal.Utils.OsString+  ( -- * Either projections+    projectStringUnknown,+    Common.projectConst,+    Common.projectFalse,+    Common.projectError,+    Common.projectErrorMap,+    Common.projectLeft,++    -- * Composing errors+    GitRevError (..),++    -- ** Functions+    runGitInEnvDirQ,++    -- ** Mapping utilities+    embedGitError,+    embedEnvError,+    embedTextError,+    Common.joinFirst,+  )+where++import Control.Exception (Exception (displayException))+import Data.Bifunctor (Bifunctor (first))+import Data.Text (Text)+import Data.Text qualified as T+import Development.GitRev.Internal.Environment.OsString (EnvError)+import Development.GitRev.Internal.Environment.OsString qualified as Env+import Development.GitRev.Internal.Git.OsString (GitError)+import Development.GitRev.Internal.Utils.Common qualified as Common+import Language.Haskell.TH (Q)+import Language.Haskell.TH.Syntax (Lift)+import System.OsString (OsString, osstr)++-- $setup+-- >>> import Development.GitRev.Typed.OsString (qToCode)+-- >>> import Development.GitRev.Internal.Git.OsString (GitError (..), gitDirtyQ, gitHashQ)+-- >>> import Development.GitRev.Internal.Environment.OsString (EnvError (..))+-- >>> import Language.Haskell.TH (Q, runIO, runQ)+-- >>> import System.Environment (setEnv)+-- >>> import System.OsString (OsString, osstr)++-- | Projects 'Left' to the string @UNKNOWN@.+--+-- ==== __Examples__+--+-- >>> $$(qToCode $ projectStringUnknown (pure $ Left ()))+-- "UNKNOWN"+--+-- @since 0.1+projectStringUnknown ::+  forall f e.+  (Functor f) =>+  f (Either e OsString) ->+  f OsString+projectStringUnknown = Common.projectConst [osstr|UNKNOWN|]++-- | General error type for anything that can go wrong when running+-- @gitrev-typed@ splices.+--+-- @since 0.1+data GitRevError+  = -- | Git error.+    --+    -- @since 0.1+    GitRevErrorGit GitError+  | -- | Environment variable lookup error.+    --+    -- @since 0.1+    GitRevErrorEnv EnvError+  | -- | Catch-all for anything else that can go wrong.+    --+    -- @since 0.1+    GitRevErrorText Text+  deriving stock+    ( -- | @since 0.1+      Eq,+      -- | @since 0.1+      Lift,+      -- | @since 0.1+      Show+    )++-- | @since 0.1+instance Exception GitRevError where+  displayException (GitRevErrorGit ge) = displayException ge+  displayException (GitRevErrorEnv x) = displayException x+  displayException (GitRevErrorText txt) = T.unpack txt++-- | Runs the git action under the directory @d@ pointed to by the+-- given environment variable.+--+-- ==== __Examples__+--+-- >>> setEnv "SOME_DIR" "./"+-- >>> $$(qToCode $ runGitInEnvDirQ [osstr|SOME_DIR|] gitHashQ)+-- Right ...+--+-- @since 0.1+runGitInEnvDirQ ::+  forall a.+  -- | Environment variable pointing to a directory path, in which we run+  -- the git process.+  OsString ->+  -- | Git process to run.+  Q (Either GitError a) ->+  -- | The result.+  Q (Either GitRevError a)+runGitInEnvDirQ var =+  fmap (Common.joinFirst GitRevErrorEnv GitRevErrorGit)+    . Env.runInEnvDirQ var++-- | Embeds a 'GitError' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either GitError ())+--       q = pure (Left $ MkGitError [osstr|not found|])+--   in runQ $ embedGitError q+-- :}+-- Left (GitRevErrorGit (MkGitError {reason = "not found"}))+--+-- @since 0.1+embedGitError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p GitError a) ->+  f (p GitRevError a)+embedGitError = fmap (first GitRevErrorGit)++-- | Embeds an 'EnvError' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either EnvError ())+--       q = pure (Left $ MkEnvError [osstr|VAR|] Nothing [osstr|VAR does not exist|])+--   in runQ $ embedEnvError q+-- :}+-- Left (GitRevErrorEnv (MkEnvError {var = "VAR", value = Nothing, reason = "VAR does not exist"}))+--+-- @since 0.1+embedEnvError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p EnvError a) ->+  f (p GitRevError a)+embedEnvError = fmap (first GitRevErrorEnv)++-- | Embeds a 'Text' in the larger 'GitRevError'.+--+-- ==== __Examples__+--+-- >>> :{+--   let q :: Q (Either Text ())+--       q = pure (Left "Something went wrong")+--   in runQ $ embedTextError q+-- :}+-- Left (GitRevErrorText "Something went wrong")+--+-- @since 0.1+embedTextError ::+  forall f p a.+  ( Bifunctor p,+    Functor f+  ) =>+  -- | .+  f (p Text a) ->+  f (p GitRevError a)+embedTextError = fmap (first GitRevErrorText)
+ src/Development/GitRev/Typed.hs view
@@ -0,0 +1,495 @@+-- |+-- Module      :  $Header$+-- Copyright   :  (c) 2025 Thomas Bidne+-- License     :  BSD3+-- Maintainer  :  tbidne@protonmail.com+--+-- Typed version of "Development.GitRev".+--+-- @since 0.1+module Development.GitRev.Typed+  ( -- * Basic functions+    -- $basic+    gitBranch,+    gitCommitCount,+    gitCommitDate,+    gitDescribe,+    gitDiff,+    gitDirty,+    gitDirtyTracked,+    gitHash,+    gitShortHash,+    gitTree,++    -- * Custom behavior+    -- $custom++    -- ** Out-of-tree builds+    -- $out-of-tree++    -- ** Multiple queries+    -- $multiple++    -- ** Git Primitives+    Git.gitBranchQ,+    Git.gitCommitCountQ,+    Git.gitCommitDateQ,+    Git.gitDescribeQ,+    Git.gitDiffQ,+    Git.gitDirtyQ,+    Git.gitDirtyTrackedQ,+    Git.gitHashQ,+    Git.gitShortHashQ,+    Git.gitTreeQ,++    -- *** Running your own git actions+    Git.runGitQ,+    Git.runGitPostProcessQ,+    IndexUsed (..),++    -- ** Environment lookup+    -- $environment+    Env.envValQ,+    Env.runInEnvDirQ,+    Utils.runGitInEnvDirQ,+    Env.withEnvValQ,++    -- ** Q to Code+    qToCode,++    -- ** Q Combinators++    -- *** Laziness+    -- $laziness+    QFirst,+    QFirst.mkQFirst,+    QFirst.unQFirst,+    QFirst.firstSuccessQ,+    Errors,+    QFirst.mkErrors,+    QFirst.unErrors,++    -- *** Eliminating Either+    Utils.projectStringUnknown,+    Utils.projectConst,+    Utils.projectFalse,+    Utils.projectError,+    Utils.projectErrorMap,+    Utils.projectLeft,++    -- ** Errors+    GitRevError (..),+    GitError (..),+    EnvError (..),++    -- *** Utilities+    Utils.embedGitError,+    Utils.embedEnvError,+    Utils.embedTextError,+    Utils.joinFirst,+  )+where++import Development.GitRev.Internal.Environment+  ( EnvError (MkEnvError),+  )+import Development.GitRev.Internal.Environment qualified as Env+import Development.GitRev.Internal.Git+  ( GitError (MkGitError),+    IndexUsed (IdxNotUsed, IdxUsed),+  )+import Development.GitRev.Internal.Git qualified as Git+import Development.GitRev.Internal.QFirst (Errors, QFirst)+import Development.GitRev.Internal.QFirst qualified as QFirst+import Development.GitRev.Internal.Utils+  ( GitRevError+      ( GitRevErrorEnv,+        GitRevErrorGit+      ),+  )+import Development.GitRev.Internal.Utils qualified as Utils+import Language.Haskell.TH (Code, Q)+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Syntax (Lift (lift), TExp (TExp))++-- $setup+-- >>> :set -XOverloadedLists+-- >>> import Data.Functor (($>))+-- >>> import Development.GitRev.Typed+-- >>> import Language.Haskell.TH (Code, Q, runIO)++-- $basic+--+-- These functions are simple, merely a typed version of "Development.GitRev"'s+-- API.+--+-- __NOTE:__ These functions do /not/ error if git fails to run, opting+-- instead to return some default value (e.g. string @UNKNOWN@, boolean @False@).++-- $custom+--+-- These functions allow defining custom behavior. For instance, using+-- the primitive 'Development.GitRev.Typed.gitHashQ' and combinator+-- 'Development.GitRev.Typed.projectError', we can define a variant of+-- 'Development.GitRev.Typed.gitHash' that instead fails to compile if there+-- are any problems with git:+--+-- @+-- -- simplified type signatures+-- 'qToCode'      :: 'Q' a -> 'Code' 'Q' a+-- 'Development.GitRev.Typed.projectError' :: 'Q' ('Either' e a) -> 'Q' a+-- 'Development.GitRev.Typed.gitHashQ'     :: 'Q' ('Either' 'GitError' 'String')+-- @+--+-- >>> :{+--   let gitHashOrDie :: Code Q String+--       gitHashOrDie = qToCode $ projectError gitHashQ+-- :}+--+-- We can also define a function that falls back to an environment variable,+-- in case the git command fails. 'Development.GitRev.Typed.firstSuccessQ'+-- takes the first action that returns 'Right'.+--+-- @+-- 'Development.GitRev.Typed.firstSuccessQ' :: 'Data.List.NonEmpty' ('Q' ('Either' e a)) -> 'Q' ('Either' ('Errors' e) a)+--+-- -- unifying errors+-- 'Development.GitRev.Typed.embedGitError' :: 'Q' ('Either' 'GitError' a) -> 'Q' ('Either' 'GitRevError' a)+-- 'Development.GitRev.Typed.embedEnvError' :: 'Q' ('Either' 'EnvError' a) -> 'Q' ('Either' 'GitRevError' a)+--+-- -- look up environment variable+-- 'Development.GitRev.Typed.envValQ' :: 'String' -> 'Q' ('Either' 'EnvError' 'String')+-- @+--+-- >>> :{+--   let gitHashEnv :: String -> Code Q (Either (Errors GitRevError) String)+--       gitHashEnv var =+--         qToCode $+--           firstSuccessQ+--             -- using -XOverloadedLists to make this a little nicer+--             -- syntactically.+--             [ embedGitError gitHashQ,+--               embedEnvError $ envValQ var+--             ]+-- :}+--+-- Naturally, these can be combined:+--+-- >>> :{+--   let gitHashEnvOrDie :: String -> Code Q String+--       gitHashEnvOrDie var =+--         qToCode+--           . projectError+--           $ firstSuccessQ+--             [ embedGitError gitHashQ,+--               embedEnvError $ envValQ var+--             ]+-- :}++-- $out-of-tree+--+-- Custom definitions are particularly useful for \"out-of-tree\" builds,+-- where the build takes place outside of the normal git tree.+--+-- These builds present a problem, as we normally rely on building in the+-- project directory where the @.git@ directory is easy to locate. For+-- example, while 'gitHash' will work for @\'cabal build\'@, it will not work+-- for @\'nix build\'@ or @\'cabal install\'@. Fortunately, there are+-- workarounds, both relying on passing the right data via environment+-- variables.+--+-- 1. Passing the git directory.+--+--     For situations where we can pass the current directory during+--     installation e.g.+--+--     > $ export EXAMPLE_HOME=$(pwd); cabal install example+--+--     We can use+--+--     @+--     'Development.GitRev.Typed.runGitInEnvDirQ' :: 'String' -> 'Q' ('Either' 'GitError' a) -> 'Q' ('Either' 'GitRevError' a)+--     @+--+--     to define+--+--     >>> :{+--       let gitHashSrcDir :: Code Q String+--           gitHashSrcDir =+--             qToCode+--             . projectStringUnknown+--             $ firstSuccessQ+--               [ -- 1. We first try normal gitHashQ.+--                 embedGitError gitHashQ,+--                 -- 2. If that fails, we try again in the directory pointed+--                 --    to by "EXAMPLE_HOME".+--                 runGitInEnvDirQ "EXAMPLE_HOME" gitHashQ+--               ]+--     :}+--+--     If the initial call to 'Development.GitRev.Typed.gitHashQ' fails, then+--     we will try again, running the command from the directory pointed to by+--     @EXAMPLE_HOME@.+--+-- 2. Passing the value itself.+--+--     This approach can work well with nix, as nix flakes provides+--     a variety of revisions via its @self@ interface. For example:+--+--     @+--       # Injecting the git hash via EXAMPLE_HASH where drv is the normal+--       # derivation.+--       drv.overrideAttrs (oldAttrs: {+--         # Also: self.shortRev, self.dirtyShortRev+--         EXAMPLE_HASH = \"${self.rev or self.dirtyRev}\";+--       });+--     @+--+--     Then we can define+--+--     >>> :{+--       let gitHashVal :: Code Q String+--           gitHashVal =+--             qToCode+--             . projectStringUnknown+--             $ firstSuccessQ+--               [ -- 1. We first try normal gitHashQ.+--                 embedGitError gitHashQ,+--                 -- 2. If that fails, get the value directly from+--                 --    "EXAMPLE_HASH".+--                 embedEnvError $ envValQ "EXAMPLE_HASH"+--               ]+--     :}+--+--     Once again, if the first attempt fails, we will run the second action,+--     looking for the value of @EXAMPLE_HASH@.+--+-- Finally, we can compose these together to make a function that works for all+-- three cases:+--+-- >>> :{+--   let gitHashValSrc :: Code Q String+--       gitHashValSrc =+--         qToCode+--           . projectStringUnknown+--           $ firstSuccessQ+--             [ embedGitError gitHashQ,+--               runGitInEnvDirQ "EXAMPLE_HOME" gitHashQ,+--               embedEnvError $ envValQ "EXAMPLE_HASH"+--             ]+-- :}++-- $multiple+--+-- Using the typed interfaced, it is easy to combine multiple queries in+-- a safe way.+--+-- >>> :{+--   import Control.Applicative (liftA3)+--   -- | Returns (date, hash, short hash)+--   gitComplexData :: Code Q (String, String, String)+--   gitComplexData = toCode qs+--     where+--       toCode = qToCode . projectError+--       qs =+--         firstSuccessQ+--           [ embedGitError gitComplexDataFromGitQ,+--             runGitInEnvDirQ "EXAMPLE_HOME" gitComplexDataFromGitQ+--           ]+--   gitComplexDataFromGitQ :: Q (Either GitError (String, String, String))+--   gitComplexDataFromGitQ = do+--     -- custom command for commit YYYY-MM-DD+--     d <- runGitQ ["log", "HEAD", "-1", "--format=%cs"] IdxNotUsed+--     h <- gitHashQ+--     sh <- gitShortHashQ+--     pure $ liftA3 (,,) d h sh+-- :}++-- $laziness+--+-- As alluded to above, 'Q'\'s default semigroup instance is not lazy enough:+--+-- >>> :{+--   $$( qToCode $+--       (runIO (putStrLn "in q1") $> (Right "q1") :: Q (Either () String))+--         <> (runIO (putStrLn "in q2") $> Left ())+--     )+-- :}+-- in q1+-- in q2+-- Right "q1"+--+-- For this reason, we introduce 'QFirst':+--+-- @+-- 'Development.GitRev.Typed.mkQFirst' :: 'Q' ('Either' e a) -> 'QFirst' e a+-- 'Development.GitRev.Typed.unQFirst' :: 'QFirst' e a -> 'Q' ('Either' ('Errors' e) a)+-- @+--+-- >>> :{+--   $$( qToCode $ unQFirst $+--       (mkQFirst $ runIO (putStrLn "in q1") $> (Right "q1") :: QFirst () String)+--         <> (mkQFirst $ runIO (putStrLn "in q2") $> Left ())+--     )+-- :}+-- in q1+-- Right "q1"+--+-- The function+--+-- @+--   'Development.GitRev.Typed.firstSuccessQ' :: 'Data.List.NonEmpty' ('Q' ('Either' e a)) -> 'Q' ('Either' ('Errors' e) a)+-- @+--+-- utilizes 'QFirst' for sequencing a series of 'Q' actions, stopping after the+-- first success.++-- $environment+--+-- This section allows looking up data via environment variables.+--+-- === Warning: caching+--+-- Suppose we install an executable @example-exe@, that depends on+-- @example-lib@, where the latter contains a TH splice for env var @FOO@.+-- We first install via:+--+-- > export FOO=A; cabal install example-exe --installdir=build --overwrite-policy=always+--+-- This will build @example-lib@ with @A@ in the splice.+--+-- Now suppose we run @cabal clean@ (or delete the build directory e.g.+-- @dist-newstyle@) and run:+--+-- > export FOO=B; cabal install example-exe --installdir=build --overwrite-policy=always+--+-- What will the result of the splice be? Probably still @A@! The problem is+-- that cabal does not know that the environment has changed, hence it detects+-- no changes, and @example-lib@ is not re-installed.+--+-- The solution is to manually delete the library @example-lib@, which+-- probably exists in the state directory e.g.+-- @~\/.local\/state\/cabal\/store\/ghc-9.8.4-inplace@.++-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@+-- if not in a git repository. For detached heads, this will just be+-- "HEAD".+--+-- ==== __Examples__+--+-- > λ. $$gitBranch+-- > "main"+--+-- @since 0.1+gitBranch :: Code Q String+gitBranch = qToCode $ Utils.projectStringUnknown Git.gitBranchQ++-- | Return the number of commits in the current head.+--+-- ==== __Examples__+--+-- > λ. $$gitCommitCount+-- > "47"+--+-- @since 0.1+gitCommitCount :: Code Q String+gitCommitCount = qToCode $ Utils.projectStringUnknown Git.gitCommitCountQ++-- | Return the commit date of the current head.+--+-- ==== __Examples__+--+-- > λ. $$gitCommitDate+-- > "Mon Apr 14 22:14:44 2025 +1200"+--+-- @since 0.1+gitCommitDate :: Code Q String+gitCommitDate = qToCode $ Utils.projectStringUnknown Git.gitCommitDateQ++-- | Return the long git description for the current git commit, or+-- @UNKNOWN@ if not in a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDescribe+-- > "1.2.0-14-g40b5d7b"+--+-- @since 0.1+gitDescribe :: Code Q String+gitDescribe = qToCode $ Utils.projectStringUnknown Git.gitDescribeQ++-- | Return the diff of the working copy with HEAD.+--+-- ==== __Examples__+--+-- > λ. $$gitDiff+-- > "diff ..."+--+-- @since 0.1+gitDiff :: Code Q String+gitDiff = qToCode $ Utils.projectStringUnknown Git.gitDiffQ++-- | Return @True@ if there are non-committed files present in the+-- repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDirty+-- > False+--+-- @since 0.1+gitDirty :: Code Q Bool+gitDirty = qToCode $ Utils.projectFalse Git.gitDirtyQ++-- | Return @True@ if there are non-commited changes to tracked files+-- present in the repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDirtyTracked+-- > False+--+-- @since 0.1+gitDirtyTracked :: Code Q Bool+gitDirtyTracked = qToCode $ Utils.projectFalse Git.gitDirtyTrackedQ++-- | Return the hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitHash+-- > "e67e943dd03744d3f93c21f84e127744e6a04543"+--+-- @since 0.1+gitHash :: Code Q String+gitHash = qToCode $ Utils.projectStringUnknown Git.gitHashQ++-- | Return the short hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitShortHash+-- > "e67e943"+--+-- @since 0.1+gitShortHash :: Code Q String+gitShortHash = qToCode $ Utils.projectStringUnknown Git.gitShortHashQ++-- | Return the hash of the current tree.+--+-- ==== __Examples__+--+-- > λ. $$gitTree+-- > "b718a493773568bbf920a4710b5b83bd1762dbb9"+--+-- @since 0.1+gitTree :: Code Q String+gitTree = qToCode $ Utils.projectStringUnknown Git.gitTreeQ++-- | Lifts a 'Q' computation to 'Code', for usage with typed TH.+--+-- @since 0.1+qToCode :: forall a. (Lift a) => Q a -> Code Q a+qToCode = TH.liftCode . fmap TExp . (>>= lift)
+ src/Development/GitRev/Typed/OsString.hs view
@@ -0,0 +1,502 @@+-- |+-- Module      :  $Header$+-- Copyright   :  (c) 2025 Thomas Bidne+-- License     :  BSD3+-- Maintainer  :  tbidne@protonmail.com+--+-- "Development.GitRev.Typed" for 'OsString'.+--+-- @since 0.1+module Development.GitRev.Typed.OsString+  ( -- * Basic functions+    -- $basic+    gitBranch,+    gitCommitCount,+    gitCommitDate,+    gitDescribe,+    gitDiff,+    gitDirty,+    gitDirtyTracked,+    gitHash,+    gitShortHash,+    gitTree,++    -- * Custom behavior+    -- $custom++    -- ** Out-of-tree builds+    -- $out-of-tree++    -- ** Multiple queries+    -- $multiple++    -- ** Git Primitives+    Git.gitBranchQ,+    Git.gitCommitCountQ,+    Git.gitCommitDateQ,+    Git.gitDescribeQ,+    Git.gitDiffQ,+    Git.gitDirtyQ,+    Git.gitDirtyTrackedQ,+    Git.gitHashQ,+    Git.gitShortHashQ,+    Git.gitTreeQ,++    -- *** Running your own git actions+    Git.runGitQ,+    Git.runGitPostProcessQ,+    IndexUsed (..),++    -- ** Environment lookup+    -- $environment+    Env.envValQ,+    Env.runInEnvDirQ,+    Utils.runGitInEnvDirQ,+    Env.withEnvValQ,++    -- ** Q to Code+    qToCode,++    -- ** Q Combinators++    -- *** Laziness+    -- $laziness+    QFirst,+    QFirst.mkQFirst,+    QFirst.unQFirst,+    QFirst.firstSuccessQ,+    Errors,+    QFirst.mkErrors,+    QFirst.unErrors,++    -- *** Eliminating Either+    Utils.projectStringUnknown,+    Utils.projectConst,+    Utils.projectFalse,+    Utils.projectError,+    Utils.projectErrorMap,+    Utils.projectLeft,++    -- ** Errors+    GitRevError (..),+    GitError (..),+    EnvError (..),++    -- *** Utilities+    Utils.embedGitError,+    Utils.embedEnvError,+    Utils.embedTextError,+    Utils.joinFirst,+  )+where++import Development.GitRev.Internal.Environment.OsString+  ( EnvError (MkEnvError),+  )+import Development.GitRev.Internal.Environment.OsString qualified as Env+import Development.GitRev.Internal.Git.OsString+  ( GitError (MkGitError),+    IndexUsed (IdxNotUsed, IdxUsed),+  )+import Development.GitRev.Internal.Git.OsString qualified as Git+import Development.GitRev.Internal.QFirst (Errors, QFirst)+import Development.GitRev.Internal.QFirst qualified as QFirst+import Development.GitRev.Internal.Utils.OsString+  ( GitRevError+      ( GitRevErrorEnv,+        GitRevErrorGit+      ),+  )+import Development.GitRev.Internal.Utils.OsString qualified as Utils+import Language.Haskell.TH (Code, Q)+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Syntax (Lift (lift), TExp (TExp))+import System.OsString (OsString)++-- $setup+-- >>> :set -XOverloadedLists+-- >>> :set -XQuasiQuotes+-- >>> import Data.Functor (($>))+-- >>> import Development.GitRev.Typed.OsString+-- >>> import Language.Haskell.TH (Code, Q, runIO)+-- >>> import System.OsString (OsString, osstr)++-- $basic+--+-- These functions are simple, merely a typed version of "Development.GitRev"'s+-- API.+--+-- __NOTE:__ These functions do /not/ error if git fails to run, opting+-- instead to return some default value (e.g. string @UNKNOWN@, boolean @False@).++-- $custom+--+-- These functions allow defining custom behavior. For instance, using+-- the primitive 'Development.GitRev.Typed.OsString.gitHashQ' and combinator+-- 'Development.GitRev.Typed.OsString.projectError', we can define a variant+-- of 'gitHash' that instead fails to compile if there are any problems with+-- git:+--+-- @+-- -- simplified type signatures+-- 'qToCode'      :: 'Q' a -> 'Code' 'Q' a+-- 'Development.GitRev.Typed.OsString.projectError' :: 'Q' ('Either' e a) -> 'Q' a+-- 'Development.GitRev.Typed.OsString.gitHashQ'     :: 'Q' ('Either' 'GitError' 'OsString')+-- @+--+-- >>> :{+--   let gitHashOrDie :: Code Q OsString+--       gitHashOrDie = qToCode $ projectError gitHashQ+-- :}+--+-- We can also define a function that falls back to an environment variable,+-- in case the git command fails.+-- 'Development.GitRev.Typed.OsString.firstSuccessQ' takes the first action+-- that returns 'Development.GitRev.Typed.OsString.Right'.+--+-- @+-- 'Development.GitRev.Typed.OsString.firstSuccessQ' :: 'Data.List.NonEmpty' ('Q' ('Either' e a)) -> 'Q' ('Either' ('Errors' e) a)+--+-- -- unifying errors+-- 'Development.GitRev.Typed.OsString.embedGitError' :: 'Q' ('Either' 'GitError' a) -> 'Q' ('Either' 'GitRevError' a)+-- 'Development.GitRev.Typed.OsString.embedEnvError' :: 'Q' ('Either' 'EnvError' a) -> 'Q' ('Either' 'GitRevError' a)+--+-- -- look up environment variable+-- 'Development.GitRev.Typed.OsString.envValQ' :: 'OsString' -> 'Q' ('Either' 'EnvError' 'OsString')+-- @+--+-- >>> :{+--   let gitHashEnv :: OsString -> Code Q (Either (Errors GitRevError) OsString)+--       gitHashEnv var =+--         qToCode $+--           firstSuccessQ+--             -- using -XOverloadedLists to make this a little nicer+--             -- syntactically.+--             [ embedGitError gitHashQ,+--               embedEnvError $ envValQ var+--             ]+-- :}+--+-- Naturally, these can be combined:+--+-- >>> :{+--   let gitHashEnvOrDie :: OsString -> Code Q OsString+--       gitHashEnvOrDie var =+--         qToCode+--           . projectError+--           $ firstSuccessQ+--             [ embedGitError gitHashQ,+--               embedEnvError $ envValQ var+--             ]+-- :}++-- $out-of-tree+--+-- Custom definitions are particularly useful for \"out-of-tree\" builds,+-- where the build takes place outside of the normal git tree.+--+-- These builds present a problem, as we normally rely on building in the+-- project directory where the @.git@ directory is easy to locate. For+-- example, while 'gitHash' will work for @\'cabal build\'@, it will not work+-- for @\'nix build\'@ or @\'cabal install\'@. Fortunately, there are+-- workarounds, both relying on passing the right data via environment+-- variables.+--+-- 1. Passing the git directory.+--+--     For situations where we can pass the current directory during+--     installation e.g.+--+--     > $ export EXAMPLE_HOME=$(pwd); cabal install example+--+--     We can use+--+--     @+--     'Development.GitRev.Typed.OsString.runGitInEnvDirQ' :: 'OsString' -> 'Q' ('Either' 'GitError' a) -> 'Q' ('Either' 'GitRevError' a)+--     @+--+--     to define+--+--     >>> :{+--       let gitHashSrcDir :: Code Q OsString+--           gitHashSrcDir =+--             qToCode+--             . projectStringUnknown+--             $ firstSuccessQ+--               [ -- 1. We first try normal gitHashQ.+--                 embedGitError gitHashQ,+--                 -- 2. If that fails, we try again in the directory pointed+--                 --    to by "EXAMPLE_HOME".+--                 runGitInEnvDirQ [osstr|EXAMPLE_HOME|] gitHashQ+--               ]+--     :}+--+--     If the initial call to 'Development.GitRev.Typed.OsString.gitHashQ'+--     fails, then we will try again, running the command from the directory+--     pointed to by @EXAMPLE_HOME@.+--+-- 2. Passing the value itself.+--+--     This approach can work well with nix, as nix flakes provides+--     a variety of revisions via its @self@ interface. For example:+--+--     @+--       # Injecting the git hash via EXAMPLE_HASH where drv is the normal+--       # derivation.+--       drv.overrideAttrs (oldAttrs: {+--         # Also: self.shortRev, self.dirtyShortRev+--         EXAMPLE_HASH = \"${self.rev or self.dirtyRev}\";+--       });+--     @+--+--     Then we can define+--+--     >>> :{+--       let gitHashVal :: Code Q OsString+--           gitHashVal =+--             qToCode+--             . projectStringUnknown+--             $ firstSuccessQ+--               [ -- 1. We first try normal gitHashQ.+--                 embedGitError gitHashQ,+--                 -- 2. If that fails, get the value directly from+--                 --    "EXAMPLE_HASH".+--                 embedEnvError $ envValQ [osstr|EXAMPLE_HASH|]+--               ]+--     :}+--+--     Once again, if the first attempt fails, we will run the second action,+--     looking for the value of @EXAMPLE_HASH@.+--+-- Finally, we can compose these together to make a function that works for all+-- three cases:+--+-- >>> :{+--   let gitHashValSrc :: Code Q OsString+--       gitHashValSrc =+--         qToCode+--           . projectStringUnknown+--           $ firstSuccessQ+--             [ embedGitError gitHashQ,+--               runGitInEnvDirQ [osstr|EXAMPLE_HOME|] gitHashQ,+--               embedEnvError $ envValQ [osstr|EXAMPLE_HASH|]+--             ]+-- :}++-- $multiple+--+-- Using the typed interfaced, it is easy to combine multiple queries in+-- a safe way.+--+-- >>> :{+--   import Control.Applicative (liftA3)+--   -- | Returns (date, hash, short hash)+--   gitComplexData :: Code Q (OsString, OsString, OsString)+--   gitComplexData = toCode qs+--     where+--       toCode = qToCode . projectError+--       qs =+--         firstSuccessQ+--           [ embedGitError gitComplexDataFromGitQ,+--             runGitInEnvDirQ [osstr|EXAMPLE_HOME|] gitComplexDataFromGitQ+--           ]+--   gitComplexDataFromGitQ :: Q (Either GitError (OsString, OsString, OsString))+--   gitComplexDataFromGitQ = do+--     -- custom command for commit YYYY-MM-DD+--     d <-+--       runGitQ+--         [[osstr|log|], [osstr|HEAD|], [osstr|-1|], [osstr|--format=%cs|]]+--         IdxNotUsed+--     h <- gitHashQ+--     sh <- gitShortHashQ+--     pure $ liftA3 (,,) d h sh+-- :}++-- $laziness+--+-- As alluded to above, 'Q'\'s default semigroup instance is not lazy enough:+--+-- >>> :{+--   $$( qToCode $+--       (runIO (putStrLn "in q1") $> (Right "q1") :: Q (Either () String))+--         <> (runIO (putStrLn "in q2") $> Left ())+--     )+-- :}+-- in q1+-- in q2+-- Right "q1"+--+-- For this reason, we introduce 'QFirst':+--+-- @+-- 'Development.GitRev.Typed.OsString.mkQFirst' :: 'Q' ('Either' e a) -> 'QFirst' e a+-- 'Development.GitRev.Typed.OsString.unQFirst' :: 'QFirst' e a -> 'Q' ('Either' ('Errors' e) a)+-- @+--+-- >>> :{+--   $$( qToCode $ unQFirst $+--       (mkQFirst $ runIO (putStrLn "in q1") $> (Right "q1") :: QFirst () String)+--         <> (mkQFirst $ runIO (putStrLn "in q2") $> Left ())+--     )+-- :}+-- in q1+-- Right "q1"+--+-- The function+--+-- @+--   'Development.GitRev.Typed.OsString.firstSuccessQ' :: 'Data.List.NonEmpty' ('Q' ('Either' e a)) -> 'Q' ('Either' ('Errors' e) a)+-- @+--+-- utilizes 'QFirst' for sequencing a series of 'Q' actions, stopping after the+-- first success.++-- $environment+--+-- This section allows looking up data via environment variables.+--+-- === Warning: caching+--+-- Suppose we install an executable @example-exe@, that depends on+-- @example-lib@, where the latter contains a TH splice for env var @FOO@.+-- We first install via:+--+-- > export FOO=A; cabal install example-exe --installdir=build --overwrite-policy=always+--+-- This will build @example-lib@ with @A@ in the splice.+--+-- Now suppose we run @cabal clean@ (or delete the build directory e.g.+-- @dist-newstyle@) and run:+--+-- > export FOO=B; cabal install example-exe --installdir=build --overwrite-policy=always+--+-- What will the result of the splice be? Probably still @A@! The problem is+-- that cabal does not know that the environment has changed, hence it detects+-- no changes, and @example-lib@ is not re-installed.+--+-- The solution is to manually delete the library @example-lib@, which+-- probably exists in the state directory e.g.+-- @~\/.local\/state\/cabal\/store\/ghc-9.8.4-inplace@.++-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@+-- if not in a git repository. For detached heads, this will just be+-- "HEAD".+--+-- ==== __Examples__+--+-- > λ. $$gitBranch+-- > "main"+--+-- @since 0.1+gitBranch :: Code Q OsString+gitBranch = qToCode $ Utils.projectStringUnknown Git.gitBranchQ++-- | Return the number of commits in the current head.+--+-- ==== __Examples__+--+-- > λ. $$gitCommitCount+-- > "47"+--+-- @since 0.1+gitCommitCount :: Code Q OsString+gitCommitCount = qToCode $ Utils.projectStringUnknown Git.gitCommitCountQ++-- | Return the commit date of the current head.+--+-- ==== __Examples__+--+-- > λ. $$gitCommitDate+-- > "Mon Apr 14 22:14:44 2025 +1200"+--+-- @since 0.1+gitCommitDate :: Code Q OsString+gitCommitDate = qToCode $ Utils.projectStringUnknown Git.gitCommitDateQ++-- | Return the long git description for the current git commit, or+-- @UNKNOWN@ if not in a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDescribe+-- > "1.2.0-14-g40b5d7b"+--+-- @since 0.1+gitDescribe :: Code Q OsString+gitDescribe = qToCode $ Utils.projectStringUnknown Git.gitDescribeQ++-- | Return the diff of the working copy with HEAD.+--+-- ==== __Examples__+--+-- > λ. $$gitDiff+-- > "diff ..."+--+-- @since 0.1+gitDiff :: Code Q OsString+gitDiff = qToCode $ Utils.projectStringUnknown Git.gitDiffQ++-- | Return @True@ if there are non-committed files present in the+-- repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDirty+-- > False+--+-- @since 0.1+gitDirty :: Code Q Bool+gitDirty = qToCode $ Utils.projectFalse Git.gitDirtyQ++-- | Return @True@ if there are non-commited changes to tracked files+-- present in the repository.+--+-- ==== __Examples__+--+-- > λ. $$gitDirtyTracked+-- > False+--+-- @since 0.1+gitDirtyTracked :: Code Q Bool+gitDirtyTracked = qToCode $ Utils.projectFalse Git.gitDirtyTrackedQ++-- | Return the hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitHash+-- > "e67e943dd03744d3f93c21f84e127744e6a04543"+--+-- @since 0.1+gitHash :: Code Q OsString+gitHash = qToCode $ Utils.projectStringUnknown Git.gitHashQ++-- | Return the short hash of the current git commit, or @UNKNOWN@ if not in+-- a git repository.+--+-- ==== __Examples__+--+-- > λ. $$gitShortHash+-- > "e67e943"+--+-- @since 0.1+gitShortHash :: Code Q OsString+gitShortHash = qToCode $ Utils.projectStringUnknown Git.gitShortHashQ++-- | Return the hash of the current tree.+--+-- ==== __Examples__+--+-- > λ. $$gitTree+-- > "b718a493773568bbf920a4710b5b83bd1762dbb9"+--+-- @since 0.1+gitTree :: Code Q OsString+gitTree = qToCode $ Utils.projectStringUnknown Git.gitTreeQ++-- | Lifts a 'Q' computation to 'Code', for usage with typed TH.+--+-- @since 0.1+qToCode :: forall a. (Lift a) => Q a -> Code Q a+qToCode = TH.liftCode . fmap TExp . (>>= lift)
+ test/unit/Main.hs view
@@ -0,0 +1,25 @@+module Main (main) where++import System.Environment.Guard (ExpectEnv (ExpectEnvSet))+import System.Environment.Guard qualified as Guard+import Test.Tasty (defaultMain, testGroup)+import Unit.Development.GitRev qualified+import Unit.Development.GitRev.Typed qualified+import Unit.Development.GitRev.Typed.OsString qualified++main :: IO ()+main = do+  Guard.guardOrElse'+    "RUN_UNIT"+    ExpectEnvSet+    runTests+    (putStrLn "*** Tests disabled. Enable with RUN_UNIT=1 ***")+  where+    runTests =+      defaultMain $+        testGroup+          "Unit"+          [ Unit.Development.GitRev.tests,+            Unit.Development.GitRev.Typed.tests,+            Unit.Development.GitRev.Typed.OsString.tests+          ]
+ test/unit/Unit/Development/GitRev.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Unit.Development.GitRev (tests) where++import Data.Text qualified as T+import Development.GitRev qualified as GR+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Utils qualified++tests :: TestTree+tests =+  testGroup+    "Development.GitRev"+    [ testGitBranch,+      testGitCommitCount,+      testGitCommitDate,+      testGitDescribe,+      testGitDirty,+      testGitDirtyTracked,+      testGitHash,+      testGitShortHash+    ]++testGitBranch :: TestTree+testGitBranch = testCase "gitBranch" $ do+  (Utils.assertDefaultText . T.pack) $GR.gitBranch++testGitCommitCount :: TestTree+testGitCommitCount = testCase "gitCommitCount" $ do+  (Utils.assertPositiveInt . T.pack) $GR.gitCommitCount++testGitCommitDate :: TestTree+testGitCommitDate = testCase "gitCommitDate" $ do+  (Utils.assertDefaultText . T.pack) $GR.gitCommitDate++testGitDescribe :: TestTree+testGitDescribe = testCase "gitDescribe" $ do+  (Utils.assertDefaultText . T.pack) $GR.gitDescribe++testGitDirty :: TestTree+testGitDirty = testCase "gitDirty" $ do+  Utils.assertBoolean $GR.gitDirty++testGitDirtyTracked :: TestTree+testGitDirtyTracked = testCase "gitDirtyTracked" $ do+  Utils.assertBoolean $GR.gitDirtyTracked++testGitHash :: TestTree+testGitHash = testCase "gitHash" $ do+  (Utils.assertHash . T.pack) $GR.gitHash++testGitShortHash :: TestTree+testGitShortHash = testCase "gitShortHash" $ do+  (Utils.assertShortHash . T.pack) $GR.gitShortHash
+ test/unit/Unit/Development/GitRev/Typed.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Unit.Development.GitRev.Typed (tests) where++import Control.Exception (Exception (displayException))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Text qualified as T+import Development.GitRev.Typed (mkErrors)+import Development.GitRev.Typed qualified as GRT+import Language.Haskell.TH (runIO)+import System.Environment qualified as Env+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@=?))+import Utils qualified++tests :: TestTree+tests =+  testGroup+    "Development.GitRev.Typed"+    [ gitTests,+      envTests,+      combinatorTests,+      semigroupTests+    ]++gitTests :: TestTree+gitTests =+  testGroup+    "Git"+    [ testGitBranch,+      testGitCommitCount,+      testGitCommitDate,+      testGitDescribe,+      testGitDiff,+      testGitDirty,+      testGitDirtyTracked,+      testGitHash,+      testGitShortHash,+      testGitTree+    ]++testGitBranch :: TestTree+testGitBranch = testCase "gitBranch" $ do+  (Utils.assertDefaultText . T.pack) $$GRT.gitBranch++testGitCommitCount :: TestTree+testGitCommitCount = testCase "gitCommitCount" $ do+  (Utils.assertPositiveInt . T.pack) $$GRT.gitCommitCount++testGitCommitDate :: TestTree+testGitCommitDate = testCase "gitCommitDate" $ do+  (Utils.assertDefaultText . T.pack) $$GRT.gitCommitDate++testGitDescribe :: TestTree+testGitDescribe = testCase "gitDescribe" $ do+  (Utils.assertDefaultText . T.pack) $$GRT.gitDescribe++testGitDiff :: TestTree+testGitDiff = testCase "gitDiff" $ do+  (Utils.assertText . T.pack) $$GRT.gitDiff++testGitDirty :: TestTree+testGitDirty = testCase "gitDirty" $ do+  Utils.assertBoolean $$GRT.gitDirty++testGitDirtyTracked :: TestTree+testGitDirtyTracked = testCase "gitDirtyTracked" $ do+  Utils.assertBoolean $$GRT.gitDirtyTracked++testGitHash :: TestTree+testGitHash = testCase "gitHash" $ do+  (Utils.assertHash . T.pack) $$GRT.gitHash++testGitShortHash :: TestTree+testGitShortHash = testCase "gitShortHash" $ do+  (Utils.assertShortHash . T.pack) $$GRT.gitShortHash++testGitTree :: TestTree+testGitTree = testCase "gitTree" $ do+  (Utils.assertHash . T.pack) $$GRT.gitTree++envTests :: TestTree+envTests =+  testGroup+    "Environment"+    [ testEnvLookupFailure,+      testRunGitInEnvBadDir+    ]++testEnvLookupFailure :: TestTree+testEnvLookupFailure = testCase desc $ do+  let result = $$(GRT.qToCode $ GRT.envValQ "SOME_BAD_VAR")+  case result of+    Right x -> assertFailure $ "Unexpected success: " ++ show x+    Left err -> expected @=? displayException err+  where+    desc = "Environment lookup should fail"+    expected =+      mconcat+        [ "Environment error with env variable 'SOME_BAD_VAR', value ",+          "<none>: No such var found."+        ]++testRunGitInEnvBadDir :: TestTree+testRunGitInEnvBadDir = testCase desc $ do+  let result =+        $$( GRT.qToCode $ do+              runIO $ Env.setEnv "SOME_GOOD_VAR" "some/bad/dir"+              GRT.runGitInEnvDirQ "SOME_GOOD_VAR" GRT.gitHashQ+          )+  case result of+    Right x -> assertFailure $ "Unexpected success: " ++ show x+    Left ex -> do+      let exStr = displayException ex+          exTxt = T.pack exStr+      assertBool+        ("Unexpected prefix: " ++ exStr)+        (expected `T.isPrefixOf` exTxt)+  where+    desc = "Run in environment dir should fail"+    expected =+      mconcat+        [ "Environment error with env variable 'SOME_GOOD_VAR', value ",+          "'some/bad/dir': Could not set directory:"+        ]++combinatorTests :: TestTree+combinatorTests =+  testGroup+    "Combinations"+    [ testLiftError,+      testHashAndEnvVal,+      testHashAndEnvDir+    ]++testLiftError :: TestTree+testLiftError = testCase "Lifts with default string" $ do+  (Utils.assertHash . T.pack)+    $$(GRT.qToCode $ GRT.projectStringUnknown GRT.gitHashQ)++testHashAndEnvVal :: TestTree+testHashAndEnvVal = testCase "Composes hash and env val lookup" $ do+  (Utils.assertHash . T.pack)+    $$( GRT.qToCode $+          GRT.projectStringUnknown $+            GRT.embedGitError GRT.gitHashQ+              <> GRT.embedEnvError (GRT.envValQ "var")+      )++testHashAndEnvDir :: TestTree+testHashAndEnvDir = testCase "Composes hash and env dir lookup" $ do+  (Utils.assertHash . T.pack)+    $$( GRT.qToCode $+          GRT.projectStringUnknown $+            GRT.embedGitError GRT.gitHashQ+              <> GRT.runGitInEnvDirQ "var" GRT.gitHashQ+      )++semigroupTests :: TestTree+semigroupTests =+  testGroup+    "Semigroup"+    [ testSemigroupQNotLazy,+      testSemigroupQFirstLazy,+      testSemigroupQFirstSuccessLazy,+      testSemigroupQFirstSuccessLazy2,+      testSemigroupQFirstSuccessAllLefts+    ]++testSemigroupQNotLazy :: TestTree+testSemigroupQNotLazy = testCase "Q Semigroup is _not_ lazy in the rhs" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qSemigroup)+  1 @=? num1+  1 @=? num2+  1 @=? num3++testSemigroupQFirstLazy :: TestTree+testSemigroupQFirstLazy = testCase "QFirst Semigroup is lazy in the rhs" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qFirstSemigroup)+  1 @=? num1+  0 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessLazy :: TestTree+testSemigroupQFirstSuccessLazy = testCase "Utils.firstSuccessQ is lazy" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qFirstSuccess)+  1 @=? num1+  0 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessLazy2 :: TestTree+testSemigroupQFirstSuccessLazy2 = testCase "Utils.firstSuccessQ is lazy 2" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qFirstSuccess2)+  1 @=? num1+  1 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessAllLefts :: TestTree+testSemigroupQFirstSuccessAllLefts = testCase desc $ do+  let ((num1, num2, num3), eResult) = $$(GRT.qToCode Utils.qFirstSuccessAllLefts)+  1 @=? num1+  1 @=? num2+  1 @=? num3++  case eResult of+    Right x -> assertFailure $ "Received Right: " ++ x+    Left result -> do+      expected @=? result+      expectedStr @=? displayException result+  where+    desc = "Utils.firstSuccessQ takes all Lefts"++    expected = mkErrors @Utils.E ("qFail1" :| ["qFail2", "qFail3"])++    expectedStr =+      mconcat+        [ "Exception(s):",+          "\n1. qFail1",+          "\n2. qFail2",+          "\n3. qFail3"+        ]
+ test/unit/Unit/Development/GitRev/Typed/OsString.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Unit.Development.GitRev.Typed.OsString (tests) where++import Control.Exception (Exception (displayException))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Text (Text)+import Data.Text qualified as T+import Development.GitRev.Typed.OsString (mkErrors)+import Development.GitRev.Typed.OsString qualified as GRT+import Language.Haskell.TH (runIO)+import System.Environment qualified as Env+import System.OsString (OsString, decodeUtf, osstr)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@=?))+import Utils qualified++tests :: TestTree+tests =+  testGroup+    "Development.GitRev.Typed.OsString"+    [ gitTests,+      envTests,+      combinatorTests,+      semigroupTests+    ]++gitTests :: TestTree+gitTests =+  testGroup+    "Git"+    [ testGitBranch,+      testGitCommitCount,+      testGitCommitDate,+      testGitDescribe,+      testGitDiff,+      testGitDirty,+      testGitDirtyTracked,+      testGitHash,+      testGitShortHash,+      testGitTree+    ]++testGitBranch :: TestTree+testGitBranch = testCase "gitBranch" $ do+  (Utils.assertDefaultText . toText) $$GRT.gitBranch++testGitCommitCount :: TestTree+testGitCommitCount = testCase "gitCommitCount" $ do+  (Utils.assertPositiveInt . toText) $$GRT.gitCommitCount++testGitCommitDate :: TestTree+testGitCommitDate = testCase "gitCommitDate" $ do+  (Utils.assertDefaultText . toText) $$GRT.gitCommitDate++testGitDescribe :: TestTree+testGitDescribe = testCase "gitDescribe" $ do+  (Utils.assertDefaultText . toText) $$GRT.gitDescribe++testGitDiff :: TestTree+testGitDiff = testCase "gitDiff" $ do+  (Utils.assertText . toText) $$GRT.gitDiff++testGitDirty :: TestTree+testGitDirty = testCase "gitDirty" $ do+  Utils.assertBoolean $$GRT.gitDirty++testGitDirtyTracked :: TestTree+testGitDirtyTracked = testCase "gitDirtyTracked" $ do+  Utils.assertBoolean $$GRT.gitDirtyTracked++testGitHash :: TestTree+testGitHash = testCase "gitHash" $ do+  (Utils.assertHash . toText) $$GRT.gitHash++testGitShortHash :: TestTree+testGitShortHash = testCase "gitShortHash" $ do+  (Utils.assertShortHash . toText) $$GRT.gitShortHash++testGitTree :: TestTree+testGitTree = testCase "gitTree" $ do+  (Utils.assertHash . toText) $$GRT.gitTree++envTests :: TestTree+envTests =+  testGroup+    "Environment"+    [ testEnvLookupFailure,+      testRunGitInEnvBadDir+    ]++testEnvLookupFailure :: TestTree+testEnvLookupFailure = testCase desc $ do+  let result = $$(GRT.qToCode $ GRT.envValQ [osstr|SOME_BAD_VAR|])+  case result of+    Right x -> assertFailure $ "Unexpected success: " ++ show x+    Left err -> expected @=? displayException err+  where+    desc = "Environment lookup should fail"+    expected =+      mconcat+        [ "Environment error with env variable 'SOME_BAD_VAR', value ",+          "<none>: No such var found."+        ]++testRunGitInEnvBadDir :: TestTree+testRunGitInEnvBadDir = testCase desc $ do+  let result =+        $$( GRT.qToCode $ do+              runIO $ Env.setEnv "SOME_GOOD_VAR" "some/bad/dir"+              GRT.runGitInEnvDirQ [osstr|SOME_GOOD_VAR|] GRT.gitHashQ+          )+  case result of+    Right x -> assertFailure $ "Unexpected success: " ++ show x+    Left ex -> do+      let exStr = displayException ex+          exTxt = T.pack exStr+      assertBool+        ("Unexpected prefix: " ++ exStr)+        (expected `T.isPrefixOf` exTxt)+  where+    desc = "Run in environment dir should fail"+    expected =+      mconcat+        [ "Environment error with env variable 'SOME_GOOD_VAR', value ",+          "'some/bad/dir': Could not set directory:"+        ]++combinatorTests :: TestTree+combinatorTests =+  testGroup+    "Combinations"+    [ testLiftError,+      testHashAndEnvVal,+      testHashAndEnvDir+    ]++testLiftError :: TestTree+testLiftError = testCase "Lifts with default string" $ do+  (Utils.assertHash . toText)+    $$(GRT.qToCode $ GRT.projectStringUnknown GRT.gitHashQ)++testHashAndEnvVal :: TestTree+testHashAndEnvVal = testCase "Composes hash and env val lookup" $ do+  (Utils.assertHash . toText)+    $$( GRT.qToCode $+          GRT.projectStringUnknown $+            GRT.embedGitError GRT.gitHashQ+              <> GRT.embedEnvError (GRT.envValQ [osstr|var|])+      )++testHashAndEnvDir :: TestTree+testHashAndEnvDir = testCase "Composes hash and env dir lookup" $ do+  (Utils.assertHash . toText)+    $$( GRT.qToCode $+          GRT.projectStringUnknown $+            GRT.embedGitError GRT.gitHashQ+              <> GRT.runGitInEnvDirQ [osstr|var|] GRT.gitHashQ+      )++semigroupTests :: TestTree+semigroupTests =+  testGroup+    "Semigroup"+    [ testSemigroupQNotLazy,+      testSemigroupQFirstLazy,+      testSemigroupQFirstSuccessLazy,+      testSemigroupQFirstSuccessLazy2,+      testSemigroupQFirstSuccessAllLefts+    ]++testSemigroupQNotLazy :: TestTree+testSemigroupQNotLazy = testCase "Q Semigroup is _not_ lazy in the rhs" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qOsSemigroup)+  1 @=? num1+  1 @=? num2+  1 @=? num3++testSemigroupQFirstLazy :: TestTree+testSemigroupQFirstLazy = testCase "QFirst Semigroup is lazy in the rhs" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qOsFirstSemigroup)+  1 @=? num1+  0 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessLazy :: TestTree+testSemigroupQFirstSuccessLazy = testCase "Utils.firstSuccessQ is lazy" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qOsFirstSuccess)+  1 @=? num1+  0 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessLazy2 :: TestTree+testSemigroupQFirstSuccessLazy2 = testCase "Utils.firstSuccessQ is lazy 2" $ do+  let (num1, num2, num3) = $$(GRT.qToCode Utils.qOsFirstSuccess2)+  1 @=? num1+  1 @=? num2+  0 @=? num3++testSemigroupQFirstSuccessAllLefts :: TestTree+testSemigroupQFirstSuccessAllLefts = testCase desc $ do+  let ((num1, num2, num3), eResult) = $$(GRT.qToCode Utils.qOsFirstSuccessAllLefts)+  1 @=? num1+  1 @=? num2+  1 @=? num3++  case eResult of+    Right x -> assertFailure $ "Received Right: " ++ show x+    Left result -> do+      expected @=? result+      expectedStr @=? displayException result+  where+    desc = "Utils.firstSuccessQ takes all Lefts"++    expected = mkErrors @Utils.E ("qFail1" :| ["qFail2", "qFail3"])++    expectedStr =+      mconcat+        [ "Exception(s):",+          "\n1. qFail1",+          "\n2. qFail2",+          "\n3. qFail3"+        ]++toText :: OsString -> Text+toText = T.pack . unsafeDecodeUtf++unsafeDecodeUtf :: OsString -> String+unsafeDecodeUtf os = case decodeUtf os of+  Left ex -> error $ displayException ex+  Right s -> s
+ test/unit/Utils.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}++module Utils+  ( -- * TH+    E (..),++    -- * String+    qSemigroup,+    qFirstSemigroup,+    qFirstSuccess,+    qFirstSuccess2,+    qFirstSuccessAllLefts,++    -- * OsString+    qOsSemigroup,+    qOsFirstSemigroup,+    qOsFirstSuccess,+    qOsFirstSuccess2,+    qOsFirstSuccessAllLefts,++    -- * Assertions+    assertBoolean,+    assertDefaultText,+    assertHash,+    assertPositiveInt,+    assertShortHash,+    assertText,+  )+where++import Control.Exception (Exception (displayException))+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.String (IsString)+import Data.Text (Text)+import Data.Text qualified as T+import Development.GitRev.Typed (Errors, unQFirst)+import Development.GitRev.Typed qualified as GRT+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (Lift)+import System.OsString (OsString, osstr)+import Test.Tasty.HUnit (assertBool, assertFailure)+import Text.Read qualified as TR++type Counter = (Int, Int, Int)++type QResult = Either E String++type QResultOs = Either E OsString++qSemigroup :: Q Counter+qSemigroup = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- q1 ref <> q2 ref <> q3 ref+  runIO $ readIORef ref++qOsSemigroup :: Q Counter+qOsSemigroup = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- qOs1 ref <> qOs2 ref <> qOs3 ref+  runIO $ readIORef ref++qFirstSemigroup :: Q Counter+qFirstSemigroup = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <-+    unQFirst $+      GRT.mkQFirst (q1 ref) <> GRT.mkQFirst (q2 ref) <> GRT.mkQFirst (q3 ref)+  runIO $ readIORef ref++qOsFirstSemigroup :: Q Counter+qOsFirstSemigroup = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <-+    unQFirst $+      GRT.mkQFirst (qOs1 ref) <> GRT.mkQFirst (qOs2 ref) <> GRT.mkQFirst (qOs3 ref)+  runIO $ readIORef ref++qFirstSuccess :: Q Counter+qFirstSuccess = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- GRT.firstSuccessQ [q1 ref, q2 ref, q3 ref]+  runIO $ readIORef ref++qOsFirstSuccess :: Q Counter+qOsFirstSuccess = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- GRT.firstSuccessQ [qOs1 ref, qOs2 ref, qOs3 ref]+  runIO $ readIORef ref++qFirstSuccess2 :: Q Counter+qFirstSuccess2 = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- GRT.firstSuccessQ [qFail1 ref, q2 ref, q3 ref]+  runIO $ readIORef ref++qOsFirstSuccess2 :: Q Counter+qOsFirstSuccess2 = do+  ref <- runIO $ newIORef (0, 0, 0)+  _ <- GRT.firstSuccessQ [qFail1 ref, qOs2 ref, qOs3 ref]+  runIO $ readIORef ref++qFirstSuccessAllLefts :: Q (Counter, Either (Errors E) String)+qFirstSuccessAllLefts = do+  ref <- runIO $ newIORef (0, 0, 0)+  result <- GRT.firstSuccessQ [qFail1 ref, qFail2 ref, qFail3 ref]+  (,result) <$> runIO (readIORef ref)++qOsFirstSuccessAllLefts :: Q (Counter, Either (Errors E) OsString)+qOsFirstSuccessAllLefts = do+  ref <- runIO $ newIORef (0, 0, 0)+  result <- GRT.firstSuccessQ [qFail1 ref, qFail2 ref, qFail3 ref]+  (,result) <$> runIO (readIORef ref)++newtype E = MkE String+  deriving stock (Eq, Lift, Show)+  deriving newtype (IsString)++instance Exception E where+  displayException (MkE s) = s++q1 :: IORef Counter -> Q QResult+q1 ref = do+  runIO $ modifyIORef' ref inc1+  pure $ Right "q1"++q2 :: IORef Counter -> Q QResult+q2 ref = do+  runIO $ modifyIORef' ref inc2+  pure $ Right "q2"++q3 :: IORef Counter -> Q QResult+q3 ref = do+  runIO $ modifyIORef' ref inc3+  pure $ Right "q3"++qOs1 :: IORef Counter -> Q QResultOs+qOs1 ref = do+  runIO $ modifyIORef' ref inc1+  pure $ Right [osstr|q1|]++qOs2 :: IORef Counter -> Q QResultOs+qOs2 ref = do+  runIO $ modifyIORef' ref inc2+  pure $ Right [osstr|q2|]++qOs3 :: IORef Counter -> Q QResultOs+qOs3 ref = do+  runIO $ modifyIORef' ref inc3+  pure $ Right [osstr|q3|]++qFail1 :: IORef Counter -> Q (Either E a)+qFail1 ref = do+  runIO $ modifyIORef' ref inc1+  pure $ Left "qFail1"++qFail2 :: IORef Counter -> Q (Either E a)+qFail2 ref = do+  runIO $ modifyIORef' ref inc2+  pure $ Left "qFail2"++qFail3 :: IORef Counter -> Q (Either E a)+qFail3 ref = do+  runIO $ modifyIORef' ref inc3+  pure $ Left "qFail3"++inc1 :: Counter -> Counter+inc1 (x, y, z) = (x + 1, y, z)++inc2 :: Counter -> Counter+inc2 (x, y, z) = (x, y + 1, z)++inc3 :: Counter -> Counter+inc3 (x, y, z) = (x, y, z + 1)++-- | Asserts text is positive int.+assertPositiveInt :: Text -> IO ()+assertPositiveInt t = do+  case TR.readMaybe @Int (T.unpack t) of+    Nothing -> assertFailure $ "Could not read int: " ++ T.unpack t+    Just n -> assertBool ("Expected > 0, received: " ++ show n) (n > 0)++-- | Asserts text is a hash.+assertHash :: Text -> IO ()+assertHash t = do+  assertBool (T.unpack t) (T.length t == 40)+  assertBool (T.unpack t) (T.all isHashChar t)+  where+    isHashChar c = T.elem c "0123456789abcdefABCDEF"++-- | Asserts text is a short hash.+assertShortHash :: Text -> IO ()+assertShortHash t = do+  assertBool (T.unpack t) (T.length t == 7)+  assertBool (T.unpack t) (T.all isHashChar t)+  where+    isHashChar c = T.elem c "0123456789abcdefABCDEF"++-- | Asserts text is non-empty and contains no newlines or carriage returns.+assertDefaultText :: Text -> IO ()+assertDefaultText t = do+  assertBool ("Expected non-empty text: " ++ T.unpack t) (not $ T.null t)+  assertBool ("Expected text without newline chars: " ++ T.unpack t) (not $ hasBadChar t)+  where+    hasBadChar = T.any (\c -> c == '\n' || c == '\r')++-- | Asserts text is not bottom.+assertText :: Text -> IO ()+assertText t = do+  -- can't make any assertions except that text is not bottom+  assertBool ("Expected text to eval: " ++ T.unpack t) (T.length t >= 0)++-- | Asserts bool is not bottom.+assertBoolean :: Bool -> IO ()+assertBoolean True = pure ()+assertBoolean False = pure ()