{-# 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 -> [Char]
projectNameFrom :: String
, Version -> [Char]
projectSynopsisFrom :: String
, Version -> [Char]
versionNumberFrom :: 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 = [Char] -> [Char] -> [Char] -> Version
Version [Char]
"" [Char]
"" [Char]
"0"
instance IsString Version where
fromString :: [Char] -> Version
fromString [Char]
x = Version
emptyVersion {versionNumberFrom :: [Char]
versionNumberFrom = [Char]
x}
fromPackage :: Q Exp
fromPackage :: Q Exp
fromPackage = do
Map Rope Rope
pairs <- Q (Map Rope Rope)
readCabalFile
let name :: Rope
name = forall a. a -> Maybe a -> a
fromMaybe Rope
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"name" forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs
let synopsis :: Rope
synopsis = forall a. a -> Maybe a -> a
fromMaybe Rope
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"synopsis" forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs
let version :: Rope
version = forall a. a -> Maybe a -> a
fromMaybe Rope
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Rope
"version" forall a b. (a -> b) -> a -> b
$ Map Rope Rope
pairs
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
}
[e|result|]
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
[Char]
file <- IO [Char]
findCabalFile
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
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 = 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
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)
__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
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))