Add file dependencies to Git files

aesiniath · Aug 28, 2023 · e7b4178 · e7b4178
1 parent d9e1e16
commit e7b4178
Show file tree

Hide file tree

Showing 4 changed files with 81 additions and 78 deletions.
diff --git a/core-program/lib/Core/Program/Metadata.hs b/core-program/lib/Core/Program/Metadata.hs
@@ -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)
 
 {- |
@@ -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
+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
@@ -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
@@ -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
@@ -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"
+                    mapM_ addDependentFile (giFiles value)
+                    pure (Just value)
diff --git a/stack.yaml b/stack.yaml
@@ -1,12 +1,13 @@
-resolver: lts-21.0
-compiler: ghc-9.4.5
+resolver: lts-21.9
+compiler: ghc-9.4.6
 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
diff --git a/tests/SimpleExperiment.hs b/tests/SimpleExperiment.hs
@@ -98,7 +98,7 @@ program = do
     info "Brr! It's cold"
 
 version :: Version
-version = $(fromPackage)
+version = $$fromPackage
 
 main :: IO ()
 main = do

diff --git a/unbeliever.cabal b/unbeliever.cabal
@@ -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 &
@@ -70,7 +70,7 @@ executable experiment
     , core-text
     , prettyprinter
     , unordered-containers
-  buildable: False
+  buildable: True
   default-language: Haskell2010
 
 executable snippet