{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Digging metadata out of the description of your project, and other useful
helpers.
-}
module Core.Program.Metadata
    ( Version
    , versionNumberFrom
    , projectNameFrom
    , projectSynopsisFrom
    , gitHashFrom
    , gitDescriptionFrom
    , gitBranchFrom

      -- * Splice
    , fromPackage

      -- * Source code
    , __LOCATION__
    ) where

import Core.Data.Structures
import Core.System.Base (IOMode (..), withFile)
import Core.System.Pretty
import Core.Text
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 System.Directory (listDirectory)

{- |
Information about the version number of this piece of software and other
related metadata related to the project it was built from. This is supplied
to your program when you call 'Core.Program.Execute.configure'. This value
is used if the user requests it by specifying the @--version@ option on the
command-line.

Simply providing an overloaded string literal such as version @\"1.0\"@
will give you a 'Version' with that value:

@
\{\-\# LANGUAGE OverloadedStrings \#\-\}

main :: 'IO' ()
main = do
    context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simpleConfig' ...
@

For more complex usage you can populate a 'Version' object using the
'fromPackage' splice below. You can then call various accessors like
'versionNumberFrom' to access individual fields.

@since 0.6.7
-}
data Version = Version
    { Version -> [Char]
projectNameFrom :: String
    , Version -> [Char]
projectSynopsisFrom :: String
    , Version -> [Char]
versionNumberFrom :: String
    , Version -> [Char]
gitHashFrom :: String
    , Version -> [Char]
gitDescriptionFrom :: String
    , Version -> [Char]
gitBranchFrom :: String
    }
    deriving (Int -> Version -> ShowS
[Version] -> ShowS
Version -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> [Char]
$cshow :: Version -> [Char]
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Version -> m Exp
forall (m :: * -> *). Quote m => Version -> Code m Version
liftTyped :: forall (m :: * -> *). Quote m => Version -> Code m Version
$cliftTyped :: forall (m :: * -> *). Quote m => Version -> Code m Version
lift :: forall (m :: * -> *). Quote m => Version -> m Exp
$clift :: forall (m :: * -> *). Quote m => Version -> m Exp
Lift)

emptyVersion :: Version
emptyVersion :: Version
emptyVersion =
    Version
        { projectNameFrom :: [Char]
projectNameFrom = [Char]
""
        , projectSynopsisFrom :: [Char]
projectSynopsisFrom = [Char]
""
        , versionNumberFrom :: [Char]
versionNumberFrom = [Char]
"0"
        , gitHashFrom :: [Char]
gitHashFrom = [Char]
""
        , gitDescriptionFrom :: [Char]
gitDescriptionFrom = [Char]
""
        , gitBranchFrom :: [Char]
gitBranchFrom = [Char]
""
        }

instance IsString Version where
    fromString :: [Char] -> Version
fromString [Char]
x = Version
emptyVersion {versionNumberFrom :: [Char]
versionNumberFrom = [Char]
x}

{- |
This is a splice which includes key built-time metadata, including the number
from the version field from your project's /.cabal/ file (as written by hand
or generated from /package.yaml/). This uses the evil @TemplateHaskell@
extension.

While we generally discourage the use of Template Haskell by beginners (there
are more important things to learn first) it is a way to execute code at
compile time and that is what what we need in order to have the version number
extracted from the /.cabal/ file rather than requiring the user to specify
(and synchronize) it in multiple places.

To use this, enable the Template Haskell language extension in your /Main.hs/
file. Then use the special @$( ... )@ \"insert splice here\" syntax that
extension provides to get a 'Version' object with the desired metadata about
your project:

@
\{\-\# LANGUAGE TemplateHaskell \#\-\}

version :: 'Version'
version = $('fromPackage')

main :: 'IO' ()
main = do
    context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simpleConfig' ...
    'Core.Program.Execute.executeWith' context program

program :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' ()
program = do
    ...
@

In addition to metadata from the Haskell package, we also extract information
from the Git repository the code was built within, if applicable. When the
program is built within a source code checkout (as is typical in continuous
integration & continuous deployment systems) then the repository is queried
for the SHA1 hash, branch name, and for whether the checkout is clean.

The resultant @--version@ output might look like the following:

@
\$ __ping --version__
ip-utils v2.0.1.9, f18ec7b
@

If, on the other hand, you had been developing locally you'll see this:

@
\$ __ping --version__
ip-utils v2.0.1.9, f18ec7b (dirty)
@

signifying that there are uncommitted files in your local tree.

If you are building the program from a relese tarball, this mechanism will
omit reporting any information about the state of a Git repository as it is
not to hand.

@since 0.6.7
-}
fromPackage :: Q Exp
fromPackage :: Q Exp
fromPackage = do
    Map Rope Rope
pairs <- Q (Map Rope Rope)
readCabalFile

    let name :: Rope
name = case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"name" Map Rope Rope
pairs of
            Maybe Rope
Nothing -> Rope
""
            Just Rope
value -> Rope
value
    let synopsis :: Rope
synopsis = case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"synopsis" Map Rope Rope
pairs of
            Maybe Rope
Nothing -> Rope
""
            Just Rope
value -> Rope
value
    let version :: Rope
version = case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"version" Map Rope Rope
pairs of
            Maybe Rope
Nothing -> Rope
""
            Just Rope
value -> Rope
"v" forall a. Semigroup a => a -> a -> a
<> Rope
value

    Maybe GitInfo
possibleInfo <- Q (Maybe GitInfo)
readGitRepository

    let full :: [Char]
full = case Maybe GitInfo
possibleInfo of
            Maybe GitInfo
Nothing -> [Char]
""
            Just GitInfo
info -> GitInfo -> [Char]
giHash GitInfo
info
    let short :: [Char]
short = case Maybe GitInfo
possibleInfo of
            Maybe GitInfo
Nothing -> [Char]
""
            Just GitInfo
info ->
                let short' :: [Char]
short' = forall a. Int -> [a] -> [a]
take Int
7 (GitInfo -> [Char]
giHash GitInfo
info)
                in  if GitInfo -> Bool
giDirty GitInfo
info
                        then [Char]
short' forall a. [a] -> [a] -> [a]
++ [Char]
" (dirty)"
                        else [Char]
short'
    let branch :: [Char]
branch = case Maybe GitInfo
possibleInfo of
            Maybe GitInfo
Nothing -> [Char]
""
            Just GitInfo
info -> GitInfo -> [Char]
giBranch GitInfo
info

    let result :: Version
result =
            Version
                { projectNameFrom :: [Char]
projectNameFrom = forall α. Textual α => Rope -> α
fromRope Rope
name
                , projectSynopsisFrom :: [Char]
projectSynopsisFrom = forall α. Textual α => Rope -> α
fromRope Rope
synopsis
                , versionNumberFrom :: [Char]
versionNumberFrom = forall α. Textual α => Rope -> α
fromRope Rope
version
                , gitHashFrom :: [Char]
gitHashFrom = [Char]
full
                , gitDescriptionFrom :: [Char]
gitDescriptionFrom = [Char]
short
                , gitBranchFrom :: [Char]
gitBranchFrom = [Char]
branch
                }

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

    [e|result|]

{-
Locate the .cabal file in the present working directory (assumed to be the
build root) and use the **Cabal** library to parse the few bits we need out
of it.
-}

findCabalFile :: IO FilePath
findCabalFile :: IO [Char]
findCabalFile = do
    [[Char]]
files <- [Char] -> IO [[Char]]
listDirectory [Char]
"."
    let found :: Maybe [Char]
found = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall a. Eq a => [a] -> [a] -> Bool
List.isSuffixOf [Char]
".cabal") [[Char]]
files
    case Maybe [Char]
found of
        Just [Char]
file -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
file
        Maybe [Char]
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"No .cabal file found"

readCabalFile :: Q (Map Rope Rope)
readCabalFile :: Q (Map Rope Rope)
readCabalFile = forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
    -- Find .cabal file
    [Char]
file <- IO [Char]
findCabalFile

    -- Parse .cabal file
    Bytes
contents <- forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
file IOMode
ReadMode Handle -> IO Bytes
hInput
    let pairs :: Map Rope Rope
pairs = Bytes -> Map Rope Rope
parseCabalFile Bytes
contents
    -- pass to calling program
    forall (m :: * -> *) a. Monad m => a -> m a
return Map Rope Rope
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
-- a proper parser would be good, but whatever.
parseCabalFile :: Bytes -> Map Rope Rope
parseCabalFile :: Bytes -> Map Rope Rope
parseCabalFile Bytes
contents =
    let breakup :: Bytes -> Map Rope Rope
breakup = forall α. Dictionary α => α -> Map (K α) (V α)
intoMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Rope
a, Rope
b) -> (Rope
a, Rope -> Rope
trimValue Rope
b)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> Rope -> (Rope, Rope)
breakRope (forall a. Eq a => a -> a -> Bool
== Char
':')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> [Rope]
breakLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. Binary α => Bytes -> α
fromBytes
    in  Bytes -> Map Rope Rope
breakup Bytes
contents

-- knock off the colon and whitespace in ":      hello"
trimValue :: Rope -> Rope
trimValue :: Rope -> Rope
trimValue Rope
value = case Rope -> Maybe (Char, Rope)
unconsRope Rope
value of
    Maybe (Char, Rope)
Nothing -> Rope
emptyRope
    Just (Char
_, Rope
remainder) -> case (Char -> Bool) -> Rope -> Maybe Int
findIndexRope (forall a. Eq a => a -> a -> Bool
/= Char
' ') Rope
remainder of
        Maybe Int
Nothing -> Rope
emptyRope
        Just Int
i -> forall a b. (a, b) -> b
snd (Int -> Rope -> (Rope, Rope)
splitRope Int
i Rope
remainder)

{- |
Access the source location of the call site.

This is insanely cool, and does /not/ require you to turn on the @CPP@ or
@TemplateHaskell@ language extensions! Nevertheless we named it with
underscores to compliment the symbols that @CPP@ gives you; the double
underscore convention holds across many languages and stands out as a very
meta thing, even if it is a proper Haskell value.

We have a 'Render' instance that simply prints the filename and line number.
Doing:

@
main :: 'IO' ()
main = 'Core.Program.Execute.execute' $ do
    'Core.Program.Logging.writeR' '__LOCATION__'
@

will give you:

@
tests/Snipppet.hs:32
@

This isn't the full stack trace, just information about the current line. If
you want more comprehensive stack trace you need to add 'HasCallStack'
constraints everywhere, and then...

@since 0.4.3
-}

-- This works because the call stack has the most recent frame at the head of
-- 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 CallStack -> [([Char], SrcLoc)]
getCallStack HasCallStack => CallStack
callStack of
        ([Char]
_, SrcLoc
srcLoc) : [([Char], SrcLoc)]
_ -> SrcLoc
srcLoc
        [([Char], SrcLoc)]
_ -> SrcLoc
emptySrcLoc
  where
    -- we construct a dud SrcLoc rather than using error "unreachable!"
    -- because often the only time you need a source location is an exception
    -- pathway already. If something goes wrong with this gimick we don't want
    -- to submerge the actual problem.
    emptySrcLoc :: SrcLoc
emptySrcLoc =
        SrcLoc
            { srcLocPackage :: [Char]
srcLocPackage = [Char]
""
            , srcLocModule :: [Char]
srcLocModule = [Char]
""
            , srcLocFile :: [Char]
srcLocFile = [Char]
""
            , srcLocStartLine :: Int
srcLocStartLine = Int
0
            , srcLocStartCol :: Int
srcLocStartCol = Int
0
            , srcLocEndLine :: Int
srcLocEndLine = Int
0
            , srcLocEndCol :: Int
srcLocEndCol = Int
0
            }

instance Render SrcLoc where
    type Token SrcLoc = ()
    colourize :: Token SrcLoc -> AnsiColour
colourize = forall a b. a -> b -> a
const AnsiColour
pureWhite
    highlight :: SrcLoc -> Doc (Token SrcLoc)
highlight SrcLoc
loc =
        forall a ann. Pretty a => a -> Doc ann
pretty (SrcLoc -> [Char]
srcLocFile SrcLoc
loc)
            forall a. Semigroup a => a -> a -> a
<> Doc ()
":"
            forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> [Char]
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc))

{- |
Information about the revision from which this piece of software was built.
The most useful field here is the \"short\", human-readable for via
'gitShortFrom', which can be used augment telemetry, for example.

@since 0.6.7
-}

{- |
This is a splice which extracts a 'Commit' object based on the repository in
which the build was run. Like the 'fromPackage' splice, this also uses the
evil @TemplateHaskell@ extension.

Note that if the application was compiled was done using a release tarball and
not built from source the values returned will be empty placeholders.

@since 0.6.7
-}
readGitRepository :: Q (Maybe GitInfo)
readGitRepository :: Q (Maybe GitInfo)
readGitRepository = do
    forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
        [Char] -> IO (Either GitHashException [Char])
getGitRoot [Char]
"." forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left GitHashException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Right [Char]
path -> do
                [Char] -> IO (Either GitHashException GitInfo)
getGitInfo [Char]
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left GitHashException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                    Right GitInfo
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just GitInfo
value)