{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Core.Program.Metadata (
Version,
versionNumberFrom,
projectNameFrom,
projectSynopsisFrom,
fromPackage,
__LOCATION__,
) where
import Core.Data
import Core.System.Base (IOMode (..), withFile)
import Core.System.Pretty
import Core.Text
import qualified Data.List as List (find, isSuffixOf)
import Data.Maybe (fromMaybe)
import Data.String
import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
import Language.Haskell.TH (Q, runIO)
import Language.Haskell.TH.Syntax (Exp (..), Lift)
import System.Directory (listDirectory)
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}
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
}
[e|result|]
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
String
file <- IO String
findCabalFile
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
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)] -> [(Rope, Rope)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Rope
a, Rope
b) -> (Rope
a, Rope -> Rope
trimValue Rope
b)) ([(Rope, Rope)] -> [(Rope, Rope)])
-> (Bytes -> [(Rope, Rope)]) -> Bytes -> [(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
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') Rope
remainder of
Maybe Int
Nothing -> Rope
emptyRope
Just Int
i -> (Rope, Rope) -> Rope
forall a b. (a, b) -> b
snd (Int -> Rope -> (Rope, Rope)
splitRope Int
i Rope
remainder)
__LOCATION__ :: HasCallStack => SrcLoc
__LOCATION__ :: SrcLoc
__LOCATION__ =
case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
(String
_, SrcLoc
srcLoc) : [(String, SrcLoc)]
_ -> SrcLoc
srcLoc
[(String, SrcLoc)]
_ -> SrcLoc
emptySrcLoc
where
emptySrcLoc :: SrcLoc
emptySrcLoc =
SrcLoc :: String -> String -> String -> Int -> Int -> Int -> Int -> SrcLoc
SrcLoc
{ srcLocPackage :: String
srcLocPackage = String
""
, srcLocModule :: String
srcLocModule = String
""
, srcLocFile :: String
srcLocFile = String
""
, 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 = AnsiColour -> () -> AnsiColour
forall a b. a -> b -> a
const AnsiColour
pureWhite
highlight :: SrcLoc -> Doc (Token SrcLoc)
highlight SrcLoc
loc =
String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (SrcLoc -> String
srcLocFile SrcLoc
loc)
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
":"
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc))