mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-11-26 12:23:38 +03:00
WIP
This commit is contained in:
Andrea Bedini
parent
35096a5737
commit
572e37cb8e
357
app/Distribution/Aeson.hs
Normal file
357
app/Distribution/Aeson.hs
Normal file
@ -0,0 +1,357 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Distribution.Aeson where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Key (fromString)
|
||||
import Data.Aeson.KeyMap qualified as KeyMap
|
||||
import Data.Aeson.Types
|
||||
import Data.Bifunctor (second)
|
||||
import Data.List (foldl1')
|
||||
import Distribution.CabalSpecVersion
|
||||
import Distribution.Compat.Lens hiding ((.=))
|
||||
import Distribution.Compat.Newtype
|
||||
import Distribution.Compiler
|
||||
import Distribution.FieldGrammar
|
||||
import Distribution.Fields
|
||||
import Distribution.ModuleName hiding (fromString)
|
||||
import Distribution.PackageDescription
|
||||
import Distribution.PackageDescription.FieldGrammar.Copy
|
||||
import Distribution.Pretty
|
||||
import Distribution.System
|
||||
import Distribution.Types.Version
|
||||
import Distribution.Types.VersionRange
|
||||
import Distribution.Utils.Generic (fromUTF8BS)
|
||||
import Distribution.Utils.Path
|
||||
import Distribution.Utils.ShortText qualified as ST
|
||||
import Language.Haskell.Extension
|
||||
|
||||
newtype ViaPretty a = ViaPretty a
|
||||
|
||||
instance Pretty a => ToJSON (ViaPretty a) where
|
||||
toJSON (ViaPretty a) = toJSON $ prettyShow a
|
||||
|
||||
newtype ViaUnpack a = ViaUnpack a
|
||||
|
||||
instance (ToJSON o, Newtype o n) => ToJSON (ViaUnpack n) where
|
||||
toJSON (ViaUnpack n) = toJSON $ unpack n
|
||||
|
||||
deriving via String instance ToJSON Token
|
||||
|
||||
deriving via String instance ToJSON Token'
|
||||
|
||||
deriving via String instance ToJSON FilePathNT
|
||||
|
||||
deriving via String instance ToJSON CompatFilePath
|
||||
|
||||
deriving via ViaUnpack CompatLicenseFile instance ToJSON CompatLicenseFile
|
||||
|
||||
deriving via (ViaPretty VersionRange) instance ToJSON VersionRange
|
||||
|
||||
deriving via ViaUnpack TestedWith instance ToJSON TestedWith
|
||||
|
||||
deriving via (ViaPretty CompilerFlavor) instance ToJSON CompilerFlavor
|
||||
|
||||
deriving via (ViaPretty SpecVersion) instance ToJSON SpecVersion
|
||||
|
||||
deriving via (ViaPretty SpecLicense) instance ToJSON SpecLicense
|
||||
|
||||
deriving via (ViaUnpack (List sep b a)) instance ToJSON a => ToJSON (List sep b a)
|
||||
|
||||
deriving via (ViaPretty (SymbolicPath from to)) instance ToJSON (SymbolicPath from to)
|
||||
|
||||
deriving via (ViaPretty BuildType) instance ToJSON BuildType
|
||||
|
||||
deriving via (ViaPretty PackageName) instance ToJSON PackageName
|
||||
|
||||
deriving via (ViaPretty Version) instance ToJSON Version
|
||||
|
||||
instance ToJSON RepoType
|
||||
|
||||
instance ToJSON KnownRepoType
|
||||
|
||||
deriving via (ViaPretty Extension) instance ToJSON Extension
|
||||
|
||||
deriving via (ViaPretty Language) instance ToJSON Language
|
||||
|
||||
deriving via (ViaUnpack (MQuoted a)) instance ToJSON a => ToJSON (MQuoted a)
|
||||
|
||||
deriving via (ViaPretty Dependency) instance ToJSON Dependency
|
||||
|
||||
deriving via (ViaPretty BenchmarkType) instance ToJSON BenchmarkType
|
||||
|
||||
deriving via (ViaPretty ForeignLibType) instance ToJSON ForeignLibType
|
||||
|
||||
deriving via (ViaPretty TestType) instance ToJSON TestType
|
||||
|
||||
deriving via (ViaPretty ExecutableScope) instance ToJSON ExecutableScope
|
||||
|
||||
deriving via (ViaPretty ForeignLibOption) instance ToJSON ForeignLibOption
|
||||
|
||||
deriving via (ViaPretty LibVersionInfo) instance ToJSON LibVersionInfo
|
||||
|
||||
deriving via (ViaPretty ModuleName) instance ToJSON ModuleName
|
||||
|
||||
deriving via (ViaPretty ModuleReexport) instance ToJSON ModuleReexport
|
||||
|
||||
deriving via (ViaPretty Mixin) instance ToJSON Mixin
|
||||
|
||||
deriving via (ViaPretty PkgconfigDependency) instance ToJSON PkgconfigDependency
|
||||
|
||||
deriving via (ViaPretty ExeDependency) instance ToJSON ExeDependency
|
||||
|
||||
deriving via (ViaPretty LegacyExeDependency) instance ToJSON LegacyExeDependency
|
||||
|
||||
deriving via (ViaPretty LibraryVisibility) instance ToJSON LibraryVisibility
|
||||
|
||||
deriving via (ViaPretty FlagName) instance ToJSON FlagName
|
||||
|
||||
deriving via (ViaPretty Arch) instance ToJSON Arch
|
||||
|
||||
deriving via (ViaPretty OS) instance ToJSON OS
|
||||
|
||||
instance ToJSON ConfVar where
|
||||
toJSON (OS os) = object ["os" .= os]
|
||||
toJSON (Arch arch) = object ["arcg" .= arch]
|
||||
toJSON (PackageFlag flag) = object ["os" .= flag]
|
||||
toJSON (Impl compiler version) = object ["compiler" .= compiler, "version" .= version]
|
||||
|
||||
instance ToJSON c => ToJSON (Condition c) where
|
||||
toJSON (Var v) = toJSON v
|
||||
toJSON (Lit b) = toJSON b
|
||||
toJSON (CNot c) = object ["not" .= c]
|
||||
toJSON (COr l r) = object ["or" .= [l, r]]
|
||||
toJSON (CAnd l r) = object ["and" .= [l, r]]
|
||||
|
||||
newtype JSONFieldGrammar s a = JsonFG
|
||||
{ fieldGrammarJSON :: CabalSpecVersion -> [Condition ConfVar] -> s -> [Pair]
|
||||
}
|
||||
deriving (Functor)
|
||||
|
||||
type JSONFieldGrammar' s = JSONFieldGrammar s s
|
||||
|
||||
jsonFieldGrammar :: CabalSpecVersion -> [Condition ConfVar] -> JSONFieldGrammar s a -> s -> [Pair]
|
||||
jsonFieldGrammar v cs fg = fieldGrammarJSON fg v cs
|
||||
|
||||
instance Applicative (JSONFieldGrammar s) where
|
||||
pure _ = JsonFG (\_ _ _ -> mempty)
|
||||
JsonFG f <*> JsonFG x = JsonFG (\v cs s -> f v cs s <> x v cs s)
|
||||
|
||||
instance FieldGrammar ToJSON JSONFieldGrammar where
|
||||
blurFieldGrammar :: ALens' a b -> JSONFieldGrammar b d -> JSONFieldGrammar a d
|
||||
blurFieldGrammar f (JsonFG fg) = JsonFG $ \v cs ->
|
||||
fg v cs . aview f
|
||||
|
||||
uniqueFieldAla :: (ToJSON b, Newtype a b) => FieldName -> (a -> b) -> ALens' s a -> JSONFieldGrammar s a
|
||||
uniqueFieldAla fn _pack l = JsonFG $ \_v cs ->
|
||||
jsonField cs fn . toJSON . pack' _pack . aview l
|
||||
|
||||
booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> JSONFieldGrammar s Bool
|
||||
booleanFieldDef fn l def = JsonFG $ \_v cs s ->
|
||||
let b = aview l s
|
||||
in if b == def
|
||||
then mempty
|
||||
else jsonField cs fn (toJSON b)
|
||||
|
||||
optionalFieldAla :: (ToJSON b, Newtype a b) => FieldName -> (a -> b) -> ALens' s (Maybe a) -> JSONFieldGrammar s (Maybe a)
|
||||
optionalFieldAla fn _pack l = JsonFG $ \_ cs s ->
|
||||
case aview l s of
|
||||
Nothing -> mempty
|
||||
Just a -> jsonField cs fn (toJSON (pack' _pack a))
|
||||
|
||||
optionalFieldDefAla :: (ToJSON b, Newtype a b, Eq a) => FieldName -> (a -> b) -> ALens' s a -> a -> JSONFieldGrammar s a
|
||||
optionalFieldDefAla fn _pack l def = JsonFG $ \_ cs s ->
|
||||
let x = aview l s
|
||||
in if x == def
|
||||
then mempty
|
||||
else jsonField cs fn (toJSON (pack' _pack x))
|
||||
|
||||
freeTextField :: FieldName -> ALens' s (Maybe String) -> JSONFieldGrammar s (Maybe String)
|
||||
freeTextField fn l = JsonFG $ \_v cs s ->
|
||||
maybe mempty (jsonField cs fn . toJSON) (aview l s)
|
||||
|
||||
freeTextFieldDef :: FieldName -> ALens' s String -> JSONFieldGrammar s String
|
||||
freeTextFieldDef fn l = JsonFG $ \_v cs ->
|
||||
jsonField cs fn . toJSON . aview l
|
||||
|
||||
freeTextFieldDefST :: FieldName -> ALens' s ST.ShortText -> JSONFieldGrammar s ST.ShortText
|
||||
freeTextFieldDefST = defaultFreeTextFieldDefST
|
||||
|
||||
monoidalFieldAla :: (ToJSON b, Monoid a, Newtype a b) => FieldName -> (a -> b) -> ALens' s a -> JSONFieldGrammar s a
|
||||
monoidalFieldAla fn _pack l = JsonFG $ \_v cs ->
|
||||
jsonField cs fn . toJSON . pack' _pack . aview l
|
||||
|
||||
prefixedFields :: FieldName -> ALens' s [(String, String)] -> JSONFieldGrammar s [(String, String)]
|
||||
prefixedFields _fnPfx l = JsonFG $ \_v _cs s ->
|
||||
[fromString n .= v | (n, v) <- aview l s]
|
||||
|
||||
knownField :: FieldName -> JSONFieldGrammar s ()
|
||||
knownField _ = pure ()
|
||||
|
||||
deprecatedSince :: CabalSpecVersion -> String -> JSONFieldGrammar s a -> JSONFieldGrammar s a
|
||||
deprecatedSince _ _ x = x
|
||||
|
||||
-- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field
|
||||
-- this doesn't affect roundtrip as `removedIn` fields cannot be parsed
|
||||
-- so invalid documents can be only manually constructed.
|
||||
removedIn _ _ x = x
|
||||
|
||||
availableSince _ _ = id
|
||||
|
||||
hiddenField _ = JsonFG (const mempty)
|
||||
|
||||
jsonField :: [Condition ConfVar] -> FieldName -> Value -> [Pair]
|
||||
jsonField cs fn v
|
||||
| v == emptyArray = mempty
|
||||
| v == emptyString = mempty
|
||||
| null cs = [fromString (fromUTF8BS fn) .= v]
|
||||
| otherwise = [fromString (fromUTF8BS fn) .= v']
|
||||
where
|
||||
v' = object ["if" .= toJSON (foldl1' CAnd cs), "then" .= v]
|
||||
|
||||
-- Should be added to aeson
|
||||
emptyString :: Value
|
||||
emptyString = String ""
|
||||
|
||||
jsonGenericPackageDescription :: GenericPackageDescription -> Value
|
||||
jsonGenericPackageDescription gpd = jsonGenericPackageDescription' v gpd
|
||||
where
|
||||
v = specVersion $ packageDescription gpd
|
||||
|
||||
jsonGenericPackageDescription' :: CabalSpecVersion -> GenericPackageDescription -> Value
|
||||
jsonGenericPackageDescription' v gpd =
|
||||
object $
|
||||
concat
|
||||
[ jsonPackageDescription v (packageDescription gpd),
|
||||
jsonSetupBInfo v (setupBuildInfo (packageDescription gpd)),
|
||||
jsonGenPackageFlags v (genPackageFlags gpd),
|
||||
jsonCondLibrary v (condLibrary gpd),
|
||||
jsonCondSubLibraries v (condSubLibraries gpd),
|
||||
jsonCondForeignLibs v (condForeignLibs gpd),
|
||||
jsonCondExecutables v (condExecutables gpd),
|
||||
jsonCondTestSuites v (condTestSuites gpd),
|
||||
jsonCondBenchmarks v (condBenchmarks gpd)
|
||||
]
|
||||
|
||||
jsonPackageDescription :: CabalSpecVersion -> PackageDescription -> [Pair]
|
||||
jsonPackageDescription v pd =
|
||||
jsonFieldGrammar v [] packageDescriptionFieldGrammar pd
|
||||
++ ["source-repos" .= jsonSourceRepos v (sourceRepos pd)]
|
||||
|
||||
jsonSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [Value]
|
||||
jsonSourceRepos v = map (jsonSourceRepo v)
|
||||
|
||||
jsonSourceRepo :: CabalSpecVersion -> SourceRepo -> Value
|
||||
jsonSourceRepo v repo =
|
||||
object (jsonFieldGrammar v [] (sourceRepoFieldGrammar kind) repo)
|
||||
where
|
||||
kind = repoKind repo
|
||||
|
||||
jsonSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [Pair]
|
||||
jsonSetupBInfo _ Nothing = mempty
|
||||
jsonSetupBInfo v (Just sbi)
|
||||
| defaultSetupDepends sbi = mempty
|
||||
| null vs = mempty
|
||||
| otherwise = ["custom-setup" .= object vs]
|
||||
where
|
||||
vs = jsonFieldGrammar v [] (setupBInfoFieldGrammar False) sbi
|
||||
|
||||
jsonGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [Pair]
|
||||
jsonGenPackageFlags v flags
|
||||
| null flags = mempty
|
||||
| otherwise = ["flags" .= flags']
|
||||
where
|
||||
flags' =
|
||||
object
|
||||
[ fromString (unFlagName name) .= object (jsonFieldGrammar v [] (flagFieldGrammar name) flag)
|
||||
| flag@(MkPackageFlag name _ _ _) <- flags
|
||||
]
|
||||
|
||||
jsonCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [Pair]
|
||||
jsonCondLibrary _ Nothing = mempty
|
||||
jsonCondLibrary v (Just condTree) = ["library" .= condTree']
|
||||
where
|
||||
condTree' = jsonCondTree2 v (libraryFieldGrammar LMainLibName) condTree
|
||||
|
||||
jsonCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [Pair]
|
||||
jsonCondSubLibraries v libs
|
||||
| null libs = mempty
|
||||
| otherwise = ["sub-libraries" .= libs']
|
||||
where
|
||||
libs' =
|
||||
object
|
||||
[ fromString (unUnqualComponentName n)
|
||||
.= jsonCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree
|
||||
| (n, condTree) <- libs
|
||||
]
|
||||
|
||||
jsonCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [Pair]
|
||||
jsonCondForeignLibs v flibs
|
||||
| null flibs = mempty
|
||||
| otherwise = ["foreign-libraries" .= flibs']
|
||||
where
|
||||
flibs' =
|
||||
object
|
||||
[ fromString (unUnqualComponentName n)
|
||||
.= jsonCondTree2 v (foreignLibFieldGrammar n) condTree
|
||||
| (n, condTree) <- flibs
|
||||
]
|
||||
|
||||
jsonCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [Pair]
|
||||
jsonCondExecutables v exes
|
||||
| null exes = mempty
|
||||
| otherwise = ["executables" .= exes']
|
||||
where
|
||||
exes' =
|
||||
object
|
||||
[ fromString (unUnqualComponentName n)
|
||||
.= jsonCondTree2 v (executableFieldGrammar n) condTree
|
||||
| (n, condTree) <- exes
|
||||
]
|
||||
|
||||
jsonCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [Pair]
|
||||
jsonCondTestSuites v suites
|
||||
| null suites = mempty
|
||||
| otherwise = ["test-suites" .= suites']
|
||||
where
|
||||
suites' =
|
||||
object
|
||||
[ fromString (unUnqualComponentName n)
|
||||
.= jsonCondTree2 v testSuiteFieldGrammar (fmap unvalidateTestSuite condTree)
|
||||
| (n, condTree) <- suites
|
||||
]
|
||||
|
||||
jsonCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [Pair]
|
||||
jsonCondBenchmarks v suites
|
||||
| null suites = mempty
|
||||
| otherwise = ["benchmarks" .= suites']
|
||||
where
|
||||
suites' =
|
||||
object
|
||||
[ fromString (unUnqualComponentName n)
|
||||
.= jsonCondTree2 v benchmarkFieldGrammar (fmap unvalidateBenchmark condTree)
|
||||
| (n, condTree) <- suites
|
||||
]
|
||||
|
||||
jsonCondTree2 :: CabalSpecVersion -> JSONFieldGrammar' s -> CondTree ConfVar [Dependency] s -> Value
|
||||
jsonCondTree2 v grammar = merge . go []
|
||||
where
|
||||
go cs (CondNode it _ ifs) =
|
||||
jsonFieldGrammar v cs grammar it ++ concatMap (jsonIf cs) ifs
|
||||
|
||||
jsonIf cs (CondBranch c thenTree Nothing) =
|
||||
go (c : cs) thenTree
|
||||
jsonIf cs (CondBranch c thenTree (Just elseTree)) =
|
||||
go (c : cs) thenTree ++ go (CNot c : cs) elseTree
|
||||
|
||||
merge :: [Pair] -> Value
|
||||
merge = Object . fmap toJSON . KeyMap.fromListWith (++) . map (second (: []))
|
||||
159
app/Distribution/PackageDescription/FieldGrammar/Copy.hs
Normal file
159
app/Distribution/PackageDescription/FieldGrammar/Copy.hs
Normal file
@ -0,0 +1,159 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--
|
||||
-- This module is a partial copy of `Distribution.PackageDescription.FieldGrammar`.
|
||||
--
|
||||
-- It is needed because that module does not export CompatFilePath and
|
||||
-- CompatLicenseFile, which are needed to call packageDescriptionFieldGrammar
|
||||
--
|
||||
module Distribution.PackageDescription.FieldGrammar.Copy
|
||||
( module Distribution.PackageDescription.FieldGrammar,
|
||||
packageDescriptionFieldGrammar,
|
||||
CompatFilePath (..),
|
||||
CompatLicenseFile (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Distribution.CabalSpecVersion
|
||||
import qualified Distribution.Compat.CharParsing as P
|
||||
import Distribution.Compat.Newtype (Newtype, pack', unpack')
|
||||
import Distribution.Compat.Prelude
|
||||
import Distribution.Compiler (CompilerFlavor (..))
|
||||
import Distribution.FieldGrammar
|
||||
import Distribution.Fields
|
||||
import Distribution.Package
|
||||
import Distribution.PackageDescription
|
||||
import Distribution.PackageDescription.FieldGrammar hiding (packageDescriptionFieldGrammar)
|
||||
import Distribution.Parsec
|
||||
import Distribution.Pretty (Pretty (..), showToken)
|
||||
import qualified Distribution.SPDX as SPDX
|
||||
import qualified Distribution.Types.Lens as L
|
||||
import Distribution.Utils.Path
|
||||
import Distribution.Version (Version, VersionRange)
|
||||
import Prelude ()
|
||||
|
||||
packageDescriptionFieldGrammar ::
|
||||
( FieldGrammar c g,
|
||||
Applicative (g PackageDescription),
|
||||
Applicative (g PackageIdentifier),
|
||||
c (Identity BuildType),
|
||||
c (Identity PackageName),
|
||||
c (Identity Version),
|
||||
c (List FSep FilePathNT String),
|
||||
c (List FSep CompatFilePath String),
|
||||
c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)),
|
||||
c (List FSep TestedWith (CompilerFlavor, VersionRange)),
|
||||
c (List VCat FilePathNT String),
|
||||
c FilePathNT,
|
||||
c CompatLicenseFile,
|
||||
c CompatFilePath,
|
||||
c SpecLicense,
|
||||
c SpecVersion
|
||||
) =>
|
||||
g PackageDescription PackageDescription
|
||||
packageDescriptionFieldGrammar =
|
||||
PackageDescription
|
||||
<$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0
|
||||
<*> blurFieldGrammar L.package packageIdentifierGrammar
|
||||
<*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE)
|
||||
<*> licenseFilesGrammar
|
||||
<*> freeTextFieldDefST "copyright" L.copyright
|
||||
<*> freeTextFieldDefST "maintainer" L.maintainer
|
||||
<*> freeTextFieldDefST "author" L.author
|
||||
<*> freeTextFieldDefST "stability" L.stability
|
||||
<*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith
|
||||
<*> freeTextFieldDefST "homepage" L.homepage
|
||||
<*> freeTextFieldDefST "package-url" L.pkgUrl
|
||||
<*> freeTextFieldDefST "bug-reports" L.bugReports
|
||||
<*> pure [] -- source-repos are stanza
|
||||
<*> freeTextFieldDefST "synopsis" L.synopsis
|
||||
<*> freeTextFieldDefST "description" L.description
|
||||
<*> freeTextFieldDefST "category" L.category
|
||||
<*> prefixedFields "x-" L.customFieldsPD
|
||||
<*> optionalField "build-type" L.buildTypeRaw
|
||||
<*> pure Nothing -- custom-setup
|
||||
-- components
|
||||
<*> pure Nothing -- lib
|
||||
<*> pure [] -- sub libs
|
||||
<*> pure [] -- executables
|
||||
<*> pure [] -- foreign libs
|
||||
<*> pure [] -- test suites
|
||||
<*> pure [] -- benchmarks
|
||||
-- * Files
|
||||
<*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles
|
||||
<*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "."
|
||||
^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "."
|
||||
<*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles
|
||||
<*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles
|
||||
<*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles
|
||||
where
|
||||
packageIdentifierGrammar =
|
||||
PackageIdentifier
|
||||
<$> uniqueField "name" L.pkgName
|
||||
<*> uniqueField "version" L.pkgVersion
|
||||
|
||||
licenseFilesGrammar =
|
||||
(++)
|
||||
-- TODO: neither field is deprecated
|
||||
-- should we pretty print license-file if there's single license file
|
||||
-- and license-files when more
|
||||
<$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles
|
||||
<*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles
|
||||
^^^ hiddenField
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- newtypes
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Compat FilePath accepts empty file path,
|
||||
-- but issues a warning.
|
||||
--
|
||||
-- There are simply too many (~1200) package definition files
|
||||
--
|
||||
-- @
|
||||
-- license-file: ""
|
||||
-- @
|
||||
--
|
||||
-- and
|
||||
--
|
||||
-- @
|
||||
-- data-dir: ""
|
||||
-- @
|
||||
--
|
||||
-- across Hackage to outrule them completely.
|
||||
-- I suspect some of them are generated (e.g. formatted) by machine.
|
||||
newtype CompatFilePath = CompatFilePath {getCompatFilePath :: FilePath} -- TODO: Change to use SymPath
|
||||
|
||||
instance Newtype String CompatFilePath
|
||||
|
||||
instance Parsec CompatFilePath where
|
||||
parsec = do
|
||||
token <- parsecToken
|
||||
if null token
|
||||
then do
|
||||
parsecWarning PWTEmptyFilePath "empty FilePath"
|
||||
return (CompatFilePath "")
|
||||
else return (CompatFilePath token)
|
||||
|
||||
instance Pretty CompatFilePath where
|
||||
pretty = showToken . getCompatFilePath
|
||||
|
||||
newtype CompatLicenseFile = CompatLicenseFile {getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile]}
|
||||
|
||||
instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile
|
||||
|
||||
-- TODO
|
||||
instance Parsec CompatLicenseFile where
|
||||
parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec
|
||||
where
|
||||
emptyToken = P.try $ do
|
||||
token <- parsecToken
|
||||
if null token
|
||||
then return (CompatLicenseFile [])
|
||||
else P.unexpected "non-empty-token"
|
||||
|
||||
instance Pretty CompatLicenseFile where
|
||||
pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile
|
||||
@ -6,15 +6,21 @@ import Codec.Archive.Tar qualified as Tar
|
||||
import Codec.Archive.Tar.Entry qualified as Tar
|
||||
import Codec.Compression.GZip qualified as GZip
|
||||
import Control.Monad (unless, when)
|
||||
import Data.Aeson (object, (.=))
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Foldable (for_)
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text.Lazy.IO qualified as TL
|
||||
import Data.Traversable (for)
|
||||
import Development.Shake
|
||||
import Development.Shake.FilePath
|
||||
import Distribution.Aeson
|
||||
import Distribution.Package
|
||||
import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Foliage.HackageSecurity hiding (ToJSON, toJSON)
|
||||
import Foliage.Meta
|
||||
import Foliage.Options
|
||||
@ -24,6 +30,7 @@ import Foliage.RemoteAsset (addFetchRemoteAssetRule)
|
||||
import Foliage.Shake
|
||||
import Foliage.Time qualified as Time
|
||||
import Hackage.Security.Util.Path (castRoot, toFilePath)
|
||||
import Text.Mustache (compileMustacheDir, renderMustache)
|
||||
|
||||
cmdBuild :: BuildOptions -> IO ()
|
||||
cmdBuild buildOptions = do
|
||||
@ -80,6 +87,25 @@ buildAction
|
||||
|
||||
packages <- getPackages inputDir
|
||||
|
||||
packageTemplate <- compileMustacheDir "package" "_templates"
|
||||
for_ packages $ \(pkgId, pkgMeta) -> do
|
||||
gpd <- case latestRevisionNumber pkgMeta of
|
||||
Just n ->
|
||||
liftIO $ readGenericPackageDescription Verbosity.normal (cabalFileRevisionPath inputDir pkgId n)
|
||||
Nothing -> do
|
||||
srcDir <- prepareSource pkgId pkgMeta
|
||||
liftIO $ readGenericPackageDescription Verbosity.normal $ srcDir </> unPackageName (pkgName pkgId) <.> "cabal"
|
||||
|
||||
liftIO $
|
||||
TL.putStrLn $
|
||||
renderMustache packageTemplate $
|
||||
object
|
||||
[ "pkgName" .= prettyShow (pkgName pkgId),
|
||||
"pkgVersion" .= prettyShow (pkgVersion pkgId),
|
||||
"pkgVersionMeta" .= pkgMeta,
|
||||
"packageDescription" .= jsonGenericPackageDescription gpd
|
||||
]
|
||||
|
||||
cabalEntries <-
|
||||
foldMap
|
||||
( \(pkgId, pkgMeta) -> do
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Foliage.Meta
|
||||
( PackageMeta (PackageMeta),
|
||||
@ -35,6 +36,7 @@ where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad (void)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord
|
||||
@ -82,6 +84,14 @@ data PackageMetaEntry = PackageMetaEntry
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
instance Aeson.ToJSON Version
|
||||
|
||||
instance Aeson.ToJSON VersionRange
|
||||
|
||||
instance Aeson.ToJSON PackageMetaEntry
|
||||
|
||||
instance Aeson.ToJSON PackageMeta
|
||||
|
||||
readPackageMeta :: FilePath -> IO PackageMeta
|
||||
readPackageMeta = Toml.decodeFile packageMetaCodec
|
||||
|
||||
@ -119,9 +129,13 @@ _VersionRange = Toml._TextBy showVersion parseVersion
|
||||
newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text}
|
||||
deriving (Show, Eq, Binary, Hashable, NFData) via Text
|
||||
|
||||
deriving via Text instance Aeson.ToJSON GitHubRepo
|
||||
|
||||
newtype GitHubRev = GitHubRev {unGitHubRev :: Text}
|
||||
deriving (Show, Eq, Binary, Hashable, NFData) via Text
|
||||
|
||||
deriving via Text instance Aeson.ToJSON GitHubRev
|
||||
|
||||
data PackageVersionSource
|
||||
= TarballSource
|
||||
{ tarballSourceURI :: URI,
|
||||
@ -135,6 +149,16 @@ data PackageVersionSource
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
instance Aeson.ToJSON PackageVersionSource where
|
||||
toJSON =
|
||||
Aeson.genericToJSON
|
||||
Aeson.defaultOptions
|
||||
{ Aeson.sumEncoding = Aeson.ObjectWithSingleField
|
||||
}
|
||||
|
||||
instance Aeson.ToJSON URI where
|
||||
toJSON = Aeson.toJSON . show
|
||||
|
||||
packageSourceCodec :: TomlCodec PackageVersionSource
|
||||
packageSourceCodec =
|
||||
Toml.dimatch matchTarballSource (uncurry TarballSource) tarballSourceCodec
|
||||
@ -187,6 +211,8 @@ data PackageVersionMeta = PackageVersionMeta
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
instance Aeson.ToJSON PackageVersionMeta
|
||||
|
||||
sourceMetaCodec :: TomlCodec PackageVersionMeta
|
||||
sourceMetaCodec =
|
||||
PackageVersionMeta
|
||||
@ -208,6 +234,8 @@ data RevisionMeta = RevisionMeta
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
instance Aeson.ToJSON RevisionMeta
|
||||
|
||||
revisionMetaCodec :: TomlCodec RevisionMeta
|
||||
revisionMetaCodec =
|
||||
RevisionMeta
|
||||
|
||||
@ -15,6 +15,8 @@ executable foliage
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: app
|
||||
other-modules:
|
||||
Distribution.Aeson
|
||||
Distribution.PackageDescription.FieldGrammar.Copy
|
||||
Distribution.Types.Orphans
|
||||
Foliage.CmdBuild
|
||||
Foliage.CmdCreateKeys
|
||||
@ -53,6 +55,7 @@ executable foliage
|
||||
network-uri ^>=2.6.4.1,
|
||||
optparse-applicative >=0.17.0.0 && <0.18,
|
||||
shake >=0.19.6 && <0.20,
|
||||
stache,
|
||||
tar >=0.5.1.1 && <0.6,
|
||||
text >=1.2.4.1 && <2.1,
|
||||
time >=1.9.3 && <1.13,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user