diff --git a/app/Distribution/Aeson.hs b/app/Distribution/Aeson.hs index cd8418a..8d6c1ea 100644 --- a/app/Distribution/Aeson.hs +++ b/app/Distribution/Aeson.hs @@ -13,11 +13,8 @@ module Distribution.Aeson where import Data.Aeson import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types -import Data.Bifunctor (second) -import Data.List (foldl1') -import Data.String (fromString) +import Data.List.NonEmpty qualified as NE import Distribution.CabalSpecVersion import Distribution.Compat.Lens hiding ((.=)) import Distribution.Compat.Newtype @@ -124,7 +121,9 @@ 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] + toJSON (Impl compiler version) + | isAnyVersion version = object ["compiler" .= compiler] + | otherwise = object ["compiler" .= compiler, "version" .= version] instance ToJSON c => ToJSON (Condition c) where toJSON (Var v) = toJSON v @@ -134,66 +133,66 @@ instance ToJSON c => ToJSON (Condition c) where toJSON (CAnd l r) = object ["and" .= [l, r]] newtype JSONFieldGrammar s a = JsonFG - { fieldGrammarJSON :: CabalSpecVersion -> [Condition ConfVar] -> s -> [Pair] + { fieldGrammarJSON :: CabalSpecVersion -> 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 +jsonFieldGrammar :: CabalSpecVersion -> JSONFieldGrammar s a -> s -> [Pair] +jsonFieldGrammar v fg = fieldGrammarJSON fg v instance Applicative (JSONFieldGrammar s) where - pure _ = JsonFG (\_ _ _ -> mempty) - JsonFG f <*> JsonFG x = JsonFG (\v cs s -> f v cs s <> x v cs s) + pure _ = JsonFG (\_ _ -> mempty) + JsonFG f <*> JsonFG x = JsonFG (\v s -> f v s <> x v 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 + blurFieldGrammar f (JsonFG fg) = JsonFG $ \v -> + fg v . 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 + uniqueFieldAla fn _pack l = JsonFG $ \_v -> + jsonField fn . toJSON . pack' _pack . aview l booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> JSONFieldGrammar s Bool - booleanFieldDef fn l def = JsonFG $ \_v cs s -> + booleanFieldDef fn l def = JsonFG $ \_v s -> let b = aview l s in if b == def then mempty - else jsonField cs fn (toJSON b) + else jsonField 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 -> + optionalFieldAla fn _pack l = JsonFG $ \_ s -> case aview l s of Nothing -> mempty - Just a -> jsonField cs fn (toJSON (pack' _pack a)) + Just a -> jsonField 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 -> + optionalFieldDefAla fn _pack l def = JsonFG $ \_ s -> let x = aview l s in if x == def then mempty - else jsonField cs fn (toJSON (pack' _pack x)) + else jsonField 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) + freeTextField fn l = JsonFG $ \_v s -> + maybe mempty (jsonField 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 + freeTextFieldDef fn l = JsonFG $ \_v -> + jsonField 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 + monoidalFieldAla fn _pack l = JsonFG $ \_v -> + jsonField fn . toJSON . pack' _pack . aview l prefixedFields :: FieldName -> ALens' s [(String, String)] -> JSONFieldGrammar s [(String, String)] - prefixedFields _fnPfx l = JsonFG $ \_v _cs s -> - [Key.fromString n .= v | (n, v) <- aview l s] + prefixedFields fnPfx l = JsonFG $ \_v s -> + [Key.fromString (fromUTF8BS fnPfx <> n) .= v | (n, v) <- aview l s] knownField :: FieldName -> JSONFieldGrammar s () knownField _ = pure () @@ -210,15 +209,12 @@ instance FieldGrammar ToJSON JSONFieldGrammar where hiddenField _ = JsonFG (const mempty) -jsonField :: [Condition ConfVar] -> FieldName -> Value -> [Pair] -jsonField cs fn v +jsonField :: FieldName -> Value -> [Pair] +jsonField fn v | v == emptyArray = mempty | v == emptyString = mempty - | null cs = [Key.fromString (fromUTF8BS fn) .= v] - | otherwise = [Key.fromString (fromUTF8BS fn) .= v'] + | otherwise = [Key.fromString (fromUTF8BS fn) .= v] where - v' = object ["if" .= toJSON (foldl1' CAnd cs), "then" .= v] - -- Should be added to aeson emptyString :: Value emptyString = String "" @@ -228,7 +224,6 @@ jsonGenericPackageDescription gpd = object $ concat [ jsonPackageDescription v (packageDescription gpd), - jsonSetupBInfo v (setupBuildInfo (packageDescription gpd)), jsonGenPackageFlags v (genPackageFlags gpd), jsonCondLibrary v (condLibrary gpd), jsonCondSubLibraries v (condSubLibraries gpd), @@ -241,110 +236,101 @@ jsonGenericPackageDescription gpd = v = specVersion $ packageDescription gpd jsonPackageDescription :: CabalSpecVersion -> PackageDescription -> [Pair] -jsonPackageDescription v pd = - jsonFieldGrammar v [] packageDescriptionFieldGrammar pd - ++ ["source-repos" .= jsonSourceRepos v (sourceRepos pd)] +jsonPackageDescription v pd@PackageDescription {sourceRepos, setupBuildInfo} = + jsonFieldGrammar v packageDescriptionFieldGrammar pd + <> jsonSourceRepos v sourceRepos + <> jsonSetupBuildInfo v setupBuildInfo -jsonSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [Value] -jsonSourceRepos v = map (jsonSourceRepo v) +jsonSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [Pair] +jsonSourceRepos v = + concatMap (\neRepos -> ["source-repository" .= NE.map (jsonSourceRepo v) neRepos]) . NE.nonEmpty + +jsonSetupBuildInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [Pair] +jsonSetupBuildInfo v = + concatMap (\sbi -> ["custom-setup" .= jsonFieldGrammar v (setupBInfoFieldGrammar False) sbi]) 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 +jsonSourceRepo v repo@SourceRepo {repoKind} = + object $ jsonFieldGrammar v (sourceRepoFieldGrammar repoKind) repo jsonGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [Pair] -jsonGenPackageFlags v flags - | null flags = mempty - | otherwise = ["flags" .= flags'] - where - flags' = - object - [ Key.fromString (unFlagName name) .= object (jsonFieldGrammar v [] (flagFieldGrammar name) flag) - | flag@(MkPackageFlag name _ _ _) <- flags - ] +jsonGenPackageFlags v = + concatMap (\neFlags -> ["flags" .= NE.map (jsonFlag v) neFlags]) . NE.nonEmpty + +jsonFlag :: CabalSpecVersion -> PackageFlag -> Value +jsonFlag v flag@(MkPackageFlag name _ _ _) = + object [Key.fromString (unFlagName name) .= jsonFieldGrammar v (flagFieldGrammar name) flag] jsonCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [Pair] -jsonCondLibrary _ Nothing = mempty -jsonCondLibrary v (Just condTree) = ["library" .= condTree'] - where - condTree' = jsonCondTree2 v (libraryFieldGrammar LMainLibName) condTree +jsonCondLibrary v = + concatMap (\condTree -> ["library" .= object (jsonCondTree v (libraryFieldGrammar LMainLibName) condTree)]) jsonCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [Pair] -jsonCondSubLibraries v libs - | null libs = mempty - | otherwise = ["sub-libraries" .= libs'] - where - libs' = - [ KeyMap.insert "name" (fromString $ unUnqualComponentName n) $ - jsonCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree - | (n, condTree) <- libs - ] +jsonCondSubLibraries v = + concatMap (\neLibs -> ["sub-libraries" .= NE.map (jsonSubLibrary v) neLibs]) . NE.nonEmpty + +jsonSubLibrary :: CabalSpecVersion -> (UnqualComponentName, CondTree ConfVar [Dependency] Library) -> Value +jsonSubLibrary v (n, condTree) = + withName (unUnqualComponentName n) $ + jsonCondTree v (libraryFieldGrammar $ LSubLibName n) condTree jsonCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [Pair] -jsonCondForeignLibs v flibs - | null flibs = mempty - | otherwise = ["foreign-libraries" .= flibs'] - where - flibs' = - [ KeyMap.insert "name" (fromString $ unUnqualComponentName n) $ - jsonCondTree2 v (foreignLibFieldGrammar n) condTree - | (n, condTree) <- flibs - ] +jsonCondForeignLibs v = + concatMap (\neFLibs -> ["foreign-libraries" .= NE.map (jsonForeignLibrary v) neFLibs]) . NE.nonEmpty + +jsonForeignLibrary :: CabalSpecVersion -> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib) -> Value +jsonForeignLibrary v (n, condTree) = + withName (unUnqualComponentName n) $ + jsonCondTree v (foreignLibFieldGrammar n) condTree jsonCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [Pair] -jsonCondExecutables v exes - | null exes = mempty - | otherwise = ["executables" .= exes'] - where - exes' = - [ KeyMap.insert "name" (fromString $ unUnqualComponentName n) $ - jsonCondTree2 v (executableFieldGrammar n) condTree - | (n, condTree) <- exes - ] +jsonCondExecutables v = + concatMap (\neExes -> ["executables" .= NE.map (jsonCondExecutable v) neExes]) . NE.nonEmpty + +jsonCondExecutable :: CabalSpecVersion -> (UnqualComponentName, CondTree ConfVar [Dependency] Executable) -> Value +jsonCondExecutable v (n, condTree) = + withName (unUnqualComponentName n) $ + jsonCondTree v (executableFieldGrammar n) condTree jsonCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [Pair] -jsonCondTestSuites v suites - | null suites = mempty - | otherwise = ["test-suites" .= suites'] - where - suites' = - [ KeyMap.insert "name" (fromString $ unUnqualComponentName n) $ - jsonCondTree2 v testSuiteFieldGrammar (fmap unvalidateTestSuite condTree) - | (n, condTree) <- suites - ] +jsonCondTestSuites v = + concatMap (\neSuites -> ["test-suites" .= NE.map (jsonCondTestSuite v) neSuites]) . NE.nonEmpty + +jsonCondTestSuite :: CabalSpecVersion -> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite) -> Value +jsonCondTestSuite v (n, condTree) = + withName (unUnqualComponentName n) $ + jsonCondTree v testSuiteFieldGrammar (fmap unvalidateTestSuite condTree) jsonCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [Pair] -jsonCondBenchmarks v suites - | null suites = mempty - | otherwise = ["benchmarks" .= suites'] +jsonCondBenchmarks v = + concatMap (\neSuites -> ["test-suites" .= NE.map (jsonCondBenchmark v) neSuites]) . NE.nonEmpty + +jsonCondBenchmark :: CabalSpecVersion -> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark) -> Value +jsonCondBenchmark v (n, condTree) = + withName (unUnqualComponentName n) $ + jsonCondTree v benchmarkFieldGrammar (fmap unvalidateBenchmark condTree) + +jsonCondTree :: CabalSpecVersion -> JSONFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [Pair] +jsonCondTree v grammar = goNode where - suites' = - [ KeyMap.insert "name" (fromString $ unUnqualComponentName n) $ - jsonCondTree2 v benchmarkFieldGrammar (fmap unvalidateBenchmark condTree) - | (n, condTree) <- suites + goNode (CondNode it _ ifs) = + jsonFieldGrammar v grammar it ++ concatMap goBranch ifs + + goBranch (CondBranch c ifTrue Nothing) = + [ "if" + .= object + [ "cond" .= c, + "then" .= object (jsonCondTree v grammar ifTrue) + ] + ] + goBranch (CondBranch c ifTrue (Just ifFalse)) = + [ "if" + .= object + [ "cond" .= c, + "then" .= object (jsonCondTree v grammar ifTrue), + "else" .= object (jsonCondTree v grammar ifFalse) + ] ] -jsonCondTree2 :: CabalSpecVersion -> JSONFieldGrammar' s -> CondTree ConfVar [Dependency] s -> KeyMap.KeyMap 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] -> KeyMap.KeyMap Value - merge = fmap toJSON . KeyMap.fromListWith (<>) . map (second (: [])) +withName :: ToJSON v => v -> [Pair] -> Value +withName n s = object $ ("name" .= n) : s diff --git a/app/Foliage/Pages.hs b/app/Foliage/Pages.hs index 786439f..afd6b39 100644 --- a/app/Foliage/Pages.hs +++ b/app/Foliage/Pages.hs @@ -14,6 +14,7 @@ module Foliage.Pages ) where +import Control.Monad (unless) import Data.Aeson (KeyValue ((.=)), ToJSON, object) import Data.Function (on, (&)) import Data.List (sortOn) @@ -23,7 +24,7 @@ import Data.Ord (Down (Down), comparing) import Data.Text.Lazy.IO.Utf8 qualified as TL import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) -import Development.Shake (Action, traced) +import Development.Shake (Action, putWarn, traced) import Distribution.Aeson (jsonGenericPackageDescription) import Distribution.Package (PackageIdentifier (pkgName, pkgVersion)) import Distribution.Pretty (prettyShow) @@ -34,7 +35,7 @@ import Foliage.Utils.Aeson (MyAesonEncoding (..)) import GHC.Generics (Generic) import System.Directory qualified as IO import System.FilePath ((>)) -import Text.Mustache (Template) +import Text.Mustache (Template, displayMustacheWarning, renderMustacheW) import Text.Mustache.Compile.TH (compileMustacheDir) import Text.Mustache.Render (renderMustache) @@ -145,18 +146,27 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions = makePackageVersionPage :: FilePath -> PreparedPackageVersion -> Action () makePackageVersionPage outputDir - PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgDesc, cabalFileRevisions, pkgVersionIsDeprecated} = + PreparedPackageVersion + { pkgId, + pkgTimestamp, + pkgVersionSource, + pkgDesc, + cabalFileRevisions, + pkgVersionIsDeprecated + } = do + let (warnings, text) = + renderMustacheW packageVersionPageTemplate $ + object + [ "pkgVersionSource" .= pkgVersionSource, + "cabalFileRevisions" .= map fst cabalFileRevisions, + "pkgDesc" .= jsonGenericPackageDescription pkgDesc, + "pkgTimestamp" .= pkgTimestamp, + "pkgVersionDeprecated" .= pkgVersionIsDeprecated + ] traced ("webpages / package / " ++ prettyShow pkgId) $ do IO.createDirectoryIfMissing True (outputDir > "package" > prettyShow pkgId) - TL.writeFile (outputDir > "package" > prettyShow pkgId > "index.html") $ - renderMustache packageVersionPageTemplate $ - object - [ "pkgVersionSource" .= pkgVersionSource, - "cabalFileRevisions" .= map fst cabalFileRevisions, - "pkgDesc" .= jsonGenericPackageDescription pkgDesc, - "pkgTimestamp" .= pkgTimestamp, - "pkgVersionDeprecated" .= pkgVersionIsDeprecated - ] + TL.writeFile (outputDir > "package" > prettyShow pkgId > "index.html") text + unless (null warnings) $ putWarn $ unlines (map displayMustacheWarning warnings) indexPageTemplate :: Template indexPageTemplate = $(compileMustacheDir "index" "templates") diff --git a/templates/cond-tree-dependency.mustache b/templates/cond-tree-dependency.mustache new file mode 100644 index 0000000..553f607 --- /dev/null +++ b/templates/cond-tree-dependency.mustache @@ -0,0 +1,9 @@ +{{#build-depends}} +
{{pkgDesc.synopsis}}
{{pkgDesc.description}}
{{pkgDesc.author}}
{{pkgDesc.maintainer}}
{{pkgDesc.license}}
{{pkgTimestamp}}
{{.}}
- {{/cabalFileRevisions}} - {{^cabalFileRevisions}} -None
- {{/cabalFileRevisions}} -{{pkgDesc.synopsis}}
+{{pkgDesc.description}}
+{{pkgDesc.author}}
+{{pkgDesc.maintainer}}
+{{pkgDesc.license}}
+{{pkgTimestamp}}
+{{.}}
+ {{/cabalFileRevisions}} + {{^cabalFileRevisions}} +None
+ {{/cabalFileRevisions}} +