{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
Dig metadata out of the description of your project.

This uses the evil /Template Haskell/ to run code at compile time that
parses the /.cabal/ file for your Haskell project and extracts various
meaningful fields.
-}
module Core.Program.Metadata (
    Version,

    -- * Splice
    fromPackage,

    -- * Internals
    versionNumberFrom,
    projectNameFrom,
    projectSynopsisFrom,
) where

import Core.Data
import Core.System (IOMode (..), withFile)
import Core.Text
import Data.List (intersperse)
import qualified Data.List as List (find, isSuffixOf)
import Data.Maybe (fromMaybe)
import Data.String
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.simple' ...
@

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.
-}
data Version = Version
    { Version -> String
projectNameFrom :: String
    , Version -> String
projectSynopsisFrom :: String
    , Version -> String
versionNumberFrom :: String
    }
    deriving (Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> String
$cshow :: Version -> String
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show, Version -> Q Exp
Version -> Q (TExp Version)
(Version -> Q Exp) -> (Version -> Q (TExp Version)) -> Lift Version
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Version -> Q (TExp Version)
$cliftTyped :: Version -> Q (TExp Version)
lift :: Version -> Q Exp
$clift :: Version -> Q Exp
Lift)

emptyVersion :: Version
emptyVersion :: Version
emptyVersion = String -> String -> String -> Version
Version String
"" String
"" String
"0"

instance IsString Version where
    fromString :: String -> Version
fromString String
x = Version
emptyVersion{versionNumberFrom :: String
versionNumberFrom = String
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/).

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.simple' ...
@

(Using Template Haskell slows down compilation of this file, but the upside
of this technique is that it avoids linking the Haskell build machinery
into your executable, saving you about 10 MB in the size of the resultant
binary)
-}
fromPackage :: Q Exp
fromPackage :: Q Exp
fromPackage = do
    Map Rope Rope
pairs <- Q (Map Rope Rope)
readCabalFile

    let name :: Rope
name = Rope -> Maybe Rope -> Rope
forall a. a -> Maybe a -> a
fromMaybe Rope
"" (Maybe Rope -> Rope)
-> (Map Rope Rope -> Maybe Rope) -> Map Rope Rope -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> Map Rope Rope -> Maybe Rope
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"name" (Map Rope Rope -> Rope) -> Map Rope Rope -> Rope
forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs
    let synopsis :: Rope
synopsis = Rope -> Maybe Rope -> Rope
forall a. a -> Maybe a -> a
fromMaybe Rope
"" (Maybe Rope -> Rope)
-> (Map Rope Rope -> Maybe Rope) -> Map Rope Rope -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> Map Rope Rope -> Maybe Rope
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"synopsis" (Map Rope Rope -> Rope) -> Map Rope Rope -> Rope
forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs
    let version :: Rope
version = Rope -> Maybe Rope -> Rope
forall a. a -> Maybe a -> a
fromMaybe Rope
"" (Maybe Rope -> Rope)
-> (Map Rope Rope -> Maybe Rope) -> Map Rope Rope -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> Map Rope Rope -> Maybe Rope
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"version" (Map Rope Rope -> Rope) -> Map Rope Rope -> Rope
forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs

    let result :: Version
result =
            Version :: String -> String -> String -> Version
Version
                { projectNameFrom :: String
projectNameFrom = Rope -> String
forall α. Textual α => Rope -> α
fromRope Rope
name
                , projectSynopsisFrom :: String
projectSynopsisFrom = Rope -> String
forall α. Textual α => Rope -> α
fromRope Rope
synopsis
                , versionNumberFrom :: String
versionNumberFrom = Rope -> String
forall α. Textual α => Rope -> α
fromRope Rope
version
                }

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

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

    -- Parse .cabal file
    Bytes
contents <- String -> IOMode -> (Handle -> IO Bytes) -> IO Bytes
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
ReadMode Handle -> IO Bytes
hInput
    let pairs :: Map Rope Rope
pairs = Bytes -> Map Rope Rope
parseCabalFile Bytes
contents
    -- pass to calling program
    Map Rope Rope -> IO (Map Rope Rope)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Rope Rope
pairs

parseCabalFile :: Bytes -> Map Rope Rope
parseCabalFile :: Bytes -> Map Rope Rope
parseCabalFile Bytes
contents =
    let breakup :: Bytes -> Map Rope Rope
breakup = [(Rope, Rope)] -> Map Rope Rope
forall α. Dictionary α => α -> Map (K α) (V α)
intoMap ([(Rope, Rope)] -> Map Rope Rope)
-> (Bytes -> [(Rope, Rope)]) -> Bytes -> Map Rope Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rope -> (Rope, Rope)) -> [Rope] -> [(Rope, Rope)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> Rope -> (Rope, Rope)
breakRope (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')) ([Rope] -> [(Rope, Rope)])
-> (Bytes -> [Rope]) -> Bytes -> [(Rope, Rope)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> [Rope]
breakLines (Rope -> [Rope]) -> (Bytes -> Rope) -> Bytes -> [Rope]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Rope
forall α. Binary α => Bytes -> α
fromBytes
     in Bytes -> Map Rope Rope
breakup Bytes
contents

-- this should probably be a function in Core.Text.Rope
breakRope :: (Char -> Bool) -> Rope -> (Rope, Rope)
breakRope :: (Char -> Bool) -> Rope -> (Rope, Rope)
breakRope Char -> Bool
predicate Rope
text =
    let pieces :: [Rope]
pieces = Int -> [Rope] -> [Rope]
forall a. Int -> [a] -> [a]
take Int
2 ((Char -> Bool) -> Rope -> [Rope]
breakPieces Char -> Bool
predicate Rope
text)
     in case [Rope]
pieces of
            [] -> (Rope
"", Rope
"")
            [Rope
one] -> (Rope
one, Rope
"")
            (Rope
one : Rope
two : [Rope]
_) -> (Rope
one, Rope -> Rope
trimRope Rope
two)

-- knock off the whitespace in "name:      hello"
trimRope :: Rope -> Rope
trimRope :: Rope -> Rope
trimRope = [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat ([Rope] -> Rope) -> (Rope -> [Rope]) -> Rope -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
intersperse Rope
" " ([Rope] -> [Rope]) -> (Rope -> [Rope]) -> Rope -> [Rope]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> [Rope]
breakWords