|
| 1 | +{-# LANGUAGE DeriveLift #-} |
| 2 | +{-# LANGUAGE NoDuplicateRecordFields #-} |
| 3 | +{-# LANGUAGE Strict #-} |
| 4 | +{-# LANGUAGE TemplateHaskell #-} |
| 5 | + |
| 6 | +module VersionInfo |
| 7 | + ( VersionInfo (..) |
| 8 | + , versionInfo |
| 9 | + ) where |
| 10 | + |
| 11 | +import Prelude.Kore |
| 12 | + |
| 13 | +import Data.Aeson |
| 14 | + ( FromJSON |
| 15 | + ) |
| 16 | +import qualified Data.Aeson as Aeson |
| 17 | +import qualified Data.List as List |
| 18 | +import qualified Development.GitRev as GitRev |
| 19 | +import qualified GHC.Generics as GHC |
| 20 | +import Language.Haskell.TH |
| 21 | + ( Exp |
| 22 | + , Q |
| 23 | + ) |
| 24 | +import qualified Language.Haskell.TH as TH |
| 25 | +import Language.Haskell.TH.Syntax |
| 26 | + ( Lift |
| 27 | + ) |
| 28 | +import qualified Language.Haskell.TH.Syntax as TH |
| 29 | +import qualified System.Directory as Directory |
| 30 | +import System.FilePath |
| 31 | + ( isRelative |
| 32 | + , joinPath |
| 33 | + , splitDirectories |
| 34 | + , takeDirectory |
| 35 | + , (</>) |
| 36 | + ) |
| 37 | + |
| 38 | +-- | Information about the current version of Kore. |
| 39 | +data VersionInfo = |
| 40 | + VersionInfo |
| 41 | + { gitHash :: !String |
| 42 | + , gitCommitDate :: !String |
| 43 | + , gitBranch :: !(Maybe String) |
| 44 | + , gitDirty :: !Bool |
| 45 | + } |
| 46 | + deriving stock (GHC.Generic) |
| 47 | + deriving stock (Lift) |
| 48 | + |
| 49 | +instance FromJSON VersionInfo |
| 50 | + |
| 51 | +-- | Produce (at compile-time) information about the current version of Kore. |
| 52 | +versionInfo :: Q Exp |
| 53 | +versionInfo = do |
| 54 | + packageRoot <- getPackageRoot |
| 55 | + let versionFile = packageRoot </> "version.json" |
| 56 | + haveVersionFile <- Directory.doesFileExist versionFile & TH.runIO |
| 57 | + if haveVersionFile |
| 58 | + then readVersionInfoFile versionFile |
| 59 | + else defaultVersionInfo |
| 60 | + where |
| 61 | + readVersionInfoFile versionFile = do |
| 62 | + result <- Aeson.eitherDecodeFileStrict' versionFile & TH.runIO |
| 63 | + either fail (TH.lift @_ @VersionInfo) result |
| 64 | + defaultVersionInfo = |
| 65 | + [| VersionInfo |
| 66 | + { gitHash = $(GitRev.gitHash) |
| 67 | + , gitCommitDate = $(GitRev.gitCommitDate) |
| 68 | + , gitBranch = Just $(GitRev.gitBranch) |
| 69 | + , gitDirty = $(GitRev.gitDirty) |
| 70 | + } |
| 71 | + |] |
| 72 | + |
| 73 | +{- | Find the root of the package. |
| 74 | +
|
| 75 | +@getPackageRoot@ looks upward from the current file (i.e. the file into which it |
| 76 | +is spliced) to find the root directory of the package. |
| 77 | +
|
| 78 | +-} |
| 79 | +getPackageRoot :: Q FilePath |
| 80 | +getPackageRoot = do |
| 81 | + bot <- takeDirectory . TH.loc_filename <$> TH.location |
| 82 | + let parents = getParents bot |
| 83 | + TH.runIO $ findPackageRoot bot parents |
| 84 | + where |
| 85 | + isProjectRoot here = Directory.doesFileExist (here </> "package.yaml") |
| 86 | + |
| 87 | + getParents bottom = |
| 88 | + bottom |
| 89 | + & splitDirectories |
| 90 | + & List.inits |
| 91 | + & reverse |
| 92 | + & map joinPath |
| 93 | + & filter (sameRelativity bottom) |
| 94 | + |
| 95 | + sameRelativity bottom = \here -> isRelative bottom == isRelative here |
| 96 | + |
| 97 | + -- Find the root directory of the current package. This module file can |
| 98 | + -- be moved safely because the package root is found at build time. |
| 99 | + findPackageRoot bot [] = |
| 100 | + fail ("Could not find package.yaml above " ++ bot) |
| 101 | + findPackageRoot bot (here : heres) = do |
| 102 | + foundRoot <- isProjectRoot here |
| 103 | + if foundRoot then Directory.makeAbsolute here else goUp |
| 104 | + where |
| 105 | + goUp = findPackageRoot bot heres |
| 106 | + |
0 commit comments