Skip to content

Add file dependencies to Git files #199

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open

Add file dependencies to Git files #199

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
130 changes: 66 additions & 64 deletions core-program/lib/Core/Program/Metadata.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -34,8 +34,8 @@ import Data.List qualified as List (find, isSuffixOf)
import Data.String
import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
import GitHash
import Language.Haskell.TH (Q, runIO)
import Language.Haskell.TH.Syntax (Exp (..), Lift)
import Language.Haskell.TH (Code, Q, bindCode, runIO)
import Language.Haskell.TH.Syntax (Lift (..), addDependentFile)
import System.Directory (listDirectory)

{- |
Expand Down Expand Up @@ -147,54 +147,51 @@ not to hand.

@since 0.6.7
-}
fromPackage :: Q Exp
fromPackage = do
pairs <- readCabalFile

let name = case lookupKeyValue "name" pairs of
Nothing -> ""
Just value -> value
let synopsis = case lookupKeyValue "synopsis" pairs of
Nothing -> ""
Just value -> value
let version = case lookupKeyValue "version" pairs of
Nothing -> ""
Just value -> "v" <> value

possibleInfo <- readGitRepository

let full = case possibleInfo of
Nothing -> ""
Just info -> giHash info
let short = case possibleInfo of
Nothing -> ""
Just info ->
let short' = take 7 (giHash info)
in if giDirty info
then short' ++ " (dirty)"
else short'
let branch = case possibleInfo of
Nothing -> ""
Just info -> giBranch info

let result =
Version
{ projectNameFrom = fromRope name
, projectSynopsisFrom = fromRope synopsis
, versionNumberFrom = fromRope version
, gitHashFrom = full
, gitDescriptionFrom = short
, gitBranchFrom = branch
}

-- I would have preferred
--
-- let e = AppE (VarE ...
-- return e
--
-- but that's not happening. So more voodoo TH nonsense instead.

[e|result|]
fromPackage :: Code Q Version
Copy link
Member

@istathar istathar Nov 10, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We need a find to return this to being in the Q monad. I like that it returns a Version (far more explicit that :: Q Exp) but I don't want to break all the applications that do

version = $(fromPackage)

right now.

fromPackage =
bindCode
( do
pairs <- readCabalFile

let name = case lookupKeyValue "name" pairs of
Nothing -> ""
Just value -> value
let synopsis = case lookupKeyValue "synopsis" pairs of
Nothing -> ""
Just value -> value
let version = case lookupKeyValue "version" pairs of
Nothing -> ""
Just value -> "v" <> value

possibleInfo <- readGitRepository

let full = case possibleInfo of
Nothing -> ""
Just info -> giHash info
let short = case possibleInfo of
Nothing -> ""
Just info ->
let short' = take 7 (giHash info)
in if giDirty info
then short' ++ " (dirty)"
else short'
let branch = case possibleInfo of
Nothing -> ""
Just info -> giBranch info

let result =
Version
{ projectNameFrom = fromRope name
, projectSynopsisFrom = fromRope synopsis
, versionNumberFrom = fromRope version
, gitHashFrom = full
, gitDescriptionFrom = short
, gitBranchFrom = branch
}

pure result
)
liftTyped

{-
Locate the .cabal file in the present working directory (assumed to be the
Expand All @@ -211,15 +208,17 @@ findCabalFile = do
Nothing -> error "No .cabal file found"

readCabalFile :: Q (Map Rope Rope)
readCabalFile = runIO $ do
readCabalFile = do
-- Find .cabal file
file <- findCabalFile
file <- runIO findCabalFile
addDependentFile file

-- Parse .cabal file
contents <- withFile file ReadMode hInput
let pairs = parseCabalFile contents
-- pass to calling program
return pairs
runIO $ do
contents <- withFile file ReadMode hInput
let pairs = parseCabalFile contents
-- pass to calling program
return pairs

-- TODO this could be improved; we really only need the data from the first
-- block of lines, with colons in them! We're probably reached the point where
Expand Down Expand Up @@ -272,7 +271,7 @@ constraints everywhere, and then...
-- the list. Huge credit to Matt Parsons for having pointed out this technique
-- at <https://twitter.com/mattoflambda/status/1460769133923028995>

__LOCATION__ :: HasCallStack => SrcLoc
__LOCATION__ :: (HasCallStack) => SrcLoc
__LOCATION__ =
case getCallStack callStack of
(_, srcLoc) : _ -> srcLoc
Expand Down Expand Up @@ -321,10 +320,13 @@ not built from source the values returned will be empty placeholders.
-}
readGitRepository :: Q (Maybe GitInfo)
readGitRepository = do
runIO $ do
getGitRoot "." >>= \case
Left _ -> pure Nothing
Right path -> do
getGitInfo path >>= \case
Left _ -> pure Nothing
Right value -> pure (Just value)
runIO (getGitRoot ".") >>= \case
Left _ -> pure Nothing
Right path -> do
runIO (getGitInfo path) >>= \case
Left _ -> pure Nothing
Right value -> do
runIO $ print (giFiles value)
addDependentFile "/home/juan/lol"
Copy link
Member

@istathar istathar Nov 9, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Heh, we need to patch this out :)

mapM_ addDependentFile (giFiles value)
pure (Just value)
23 changes: 12 additions & 11 deletions stack.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,13 @@
resolver: lts-21.0
compiler: ghc-9.4.5
resolver: lts-21.9
compiler: ghc-9.4.6
Comment on lines +1 to +2
Copy link
Contributor Author

@guaraqe guaraqe Aug 28, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I updated the Stack snapshot.

packages:
- ./core-data
- ./core-effect-effectful
- ./core-text
- ./core-program
- ./core-telemetry
- ./core-webserver-servant
- ./core-webserver-warp
- .
extra-deps: []
- ./core-data
- ./core-effect-effectful
- ./core-text
- ./core-program
- ./core-telemetry
- ./core-webserver-servant
- ./core-webserver-warp
- .
extra-deps:
- githash-0.1.7.0
2 changes: 1 addition & 1 deletion tests/SimpleExperiment.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -98,7 +98,7 @@ program = do
info "Brr! It's cold"

version :: Version
version = $(fromPackage)
version = $$fromPackage
Copy link
Contributor Author

@guaraqe guaraqe Aug 28, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This makes the package use the same system as githash itself, see the change in type signature in fromPackage.

Copy link
Member

@istathar istathar Aug 29, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this a breaking change? Every single program built with this library uses fromPackage in its current form.


main :: IO ()
main = do
Expand Down
4 changes: 2 additions & 2 deletions unbeliever.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack

name: unbeliever
version: 0.11.3.2
version: 0.11.3.3
synopsis: Opinionated Haskell Interoperability
description: A library to help build command-line programs, both tools and
longer-running daemons. Its @Program@ type provides unified ouptut &
Expand Down Expand Up @@ -70,7 +70,7 @@ executable experiment
, core-text
, prettyprinter
, unordered-containers
buildable: False
buildable: True
Copy link
Contributor Author

@guaraqe guaraqe Aug 28, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is just for testing, we can remove it after.

default-language: Haskell2010

executable snippet
Expand Down