diff --git a/src/Data/Aeson/Config/FromValue.hs b/src/Data/Aeson/Config/FromValue.hs index 35cd0170..38ba87b0 100644 --- a/src/Data/Aeson/Config/FromValue.hs +++ b/src/Data/Aeson/Config/FromValue.hs @@ -7,6 +7,10 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveFunctor #-} module Data.Aeson.Config.FromValue ( FromValue(..) , Parser @@ -37,18 +41,24 @@ module Data.Aeson.Config.FromValue ( , Value(..) , Object , Array + +, Alias(..) +, unAlias ) where import Imports import Data.Monoid (Last(..)) import GHC.Generics +import GHC.TypeLits +import Data.Proxy import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.Vector as V import Data.Aeson.Config.Key (Key) import qualified Data.Aeson.Config.Key as Key +import Data.Aeson.Config.KeyMap (member) import qualified Data.Aeson.Config.KeyMap as KeyMap import Data.Aeson.Types (FromJSON(..)) @@ -148,7 +158,26 @@ instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (Recor instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (RecordField sel (Last a)) where genericDecode = accessFieldWith (\ value key -> Last <$> (value .:? key)) +instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownSymbol alias) => GenericDecode (RecordField sel (Alias alias (Maybe a))) where + genericDecode = accessFieldWith (\ value key -> aliasAccess (.:?) value (Alias key)) + +instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownSymbol alias) => GenericDecode (RecordField sel (Alias alias (Last a))) where + genericDecode = accessFieldWith (\ value key -> fmap Last <$> aliasAccess (.:?) value (Alias key)) + +aliasAccess :: forall a alias. KnownSymbol alias => (Object -> Key -> Parser a) -> Object -> (Alias alias Key) -> Parser (Alias alias a) +aliasAccess op value (Alias key) + | alias `member` value && not (key `member` value) = Alias <$> value `op` alias + | otherwise = Alias <$> value `op` key + where + alias = Key.fromString (symbolVal $ Proxy @alias) + accessFieldWith :: forall sel a p. Selector sel => (Object -> Key -> Parser a) -> Options -> Value -> Parser (RecordField sel a p) accessFieldWith op Options{..} v = M1 . K1 <$> withObject (`op` Key.fromString label) v where label = optionsRecordSelectorModifier $ selName (undefined :: RecordField sel a p) + +newtype Alias (alias :: Symbol) a = Alias a + deriving (Show, Eq, Semigroup, Functor) + +unAlias :: Alias alias a -> a +unAlias (Alias a) = a diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index cffa7a96..82f9226e 100644 --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -13,6 +13,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} module Hpack.Config ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following @@ -224,18 +225,18 @@ instance Semigroup LibrarySection where } data ExecutableSection = ExecutableSection { - executableSectionMain :: Maybe FilePath + executableSectionMain :: Alias "main-is" (Last FilePath) , executableSectionOtherModules :: Maybe (List Module) , executableSectionGeneratedOtherModules :: Maybe (List Module) } deriving (Eq, Show, Generic, FromValue) instance Monoid ExecutableSection where - mempty = ExecutableSection Nothing Nothing Nothing + mempty = ExecutableSection (Alias $ Last Nothing) Nothing Nothing mappend = (<>) instance Semigroup ExecutableSection where a <> b = ExecutableSection { - executableSectionMain = executableSectionMain b <|> executableSectionMain a + executableSectionMain = executableSectionMain a <> executableSectionMain b , executableSectionOtherModules = executableSectionOtherModules a <> executableSectionOtherModules b , executableSectionGeneratedOtherModules = executableSectionGeneratedOtherModules a <> executableSectionGeneratedOtherModules b } @@ -268,9 +269,9 @@ instance FromValue Verbatim where _ -> typeMismatch (formatOrList ["String", "Object"]) v data CommonOptions cSources cxxSources jsSources a = CommonOptions { - commonOptionsSourceDirs :: Maybe (List FilePath) -, commonOptionsDependencies :: Maybe Dependencies -, commonOptionsPkgConfigDependencies :: Maybe (List String) + commonOptionsSourceDirs :: Alias "hs-source-dirs" (Maybe (List FilePath)) +, commonOptionsDependencies :: Alias "build-depends" (Maybe Dependencies) +, commonOptionsPkgConfigDependencies :: Alias "pkgconfig-depends" (Maybe (List String)) , commonOptionsDefaultExtensions :: Maybe (List String) , commonOptionsOtherExtensions :: Maybe (List String) , commonOptionsDefaultLanguage :: Last Language @@ -292,7 +293,7 @@ data CommonOptions cSources cxxSources jsSources a = CommonOptions { , commonOptionsLdOptions :: Maybe (List LdOption) , commonOptionsBuildable :: Maybe Bool , commonOptionsWhen :: Maybe (List (ConditionalSection cSources cxxSources jsSources a)) -, commonOptionsBuildTools :: Maybe BuildTools +, commonOptionsBuildTools :: Alias "build-tool-depends" (Maybe BuildTools) , commonOptionsSystemBuildTools :: Maybe SystemBuildTools , commonOptionsVerbatim :: Maybe (List Verbatim) } deriving (Functor, Generic) @@ -302,9 +303,9 @@ instance FromValue a => FromValue (ParseCommonOptions a) instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources, Monoid cSources, Monoid cxxSources, Monoid jsSources) => Monoid (CommonOptions cSources cxxSources jsSources a) where mempty = CommonOptions { - commonOptionsSourceDirs = Nothing - , commonOptionsDependencies = Nothing - , commonOptionsPkgConfigDependencies = Nothing + commonOptionsSourceDirs = Alias Nothing + , commonOptionsDependencies = Alias Nothing + , commonOptionsPkgConfigDependencies = Alias Nothing , commonOptionsDefaultExtensions = Nothing , commonOptionsOtherExtensions = Nothing , commonOptionsDefaultLanguage = Last Nothing @@ -326,7 +327,7 @@ instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources, Monoid , commonOptionsLdOptions = Nothing , commonOptionsBuildable = Nothing , commonOptionsWhen = Nothing - , commonOptionsBuildTools = Nothing + , commonOptionsBuildTools = Alias Nothing , commonOptionsSystemBuildTools = Nothing , commonOptionsVerbatim = Nothing } @@ -1416,7 +1417,7 @@ fromLibrarySectionPlain LibrarySection{..} = Library { } getMentionedExecutableModules :: ExecutableSection -> [Module] -getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)= +getMentionedExecutableModules (ExecutableSection (Alias (Last main)) otherModules generatedModules)= maybe id (:) (toModule . Path.fromFilePath <$> main) $ fromMaybeList (otherModules <> generatedModules) toExecutable :: FilePath -> String -> Section ExecutableSection -> IO (Section Executable) @@ -1426,7 +1427,7 @@ toExecutable dir packageName_ = where fromExecutableSection :: [Module] -> [Module] -> ExecutableSection -> Executable fromExecutableSection pathsModule inferableModules ExecutableSection{..} = - (Executable executableSectionMain (otherModules ++ generatedModules) generatedModules) + (Executable (getLast $ unAlias executableSectionMain) (otherModules ++ generatedModules) generatedModules) where otherModules = maybe (inferableModules ++ pathsModule) fromList executableSectionOtherModules generatedModules = maybe [] fromList executableSectionGeneratedOtherModules @@ -1439,9 +1440,9 @@ expandMain = flatten . expand where go exec@ExecutableSection{..} = let - (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) executableSectionMain + (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) (getLast $ unAlias executableSectionMain) in - (ghcOptions, exec{executableSectionMain = mainSrcFile}) + (ghcOptions, exec{executableSectionMain = Alias $ Last mainSrcFile}) flatten :: Section ([GhcOption], ExecutableSection) -> Section ExecutableSection flatten sect@Section{sectionData = (ghcOptions, exec), ..} = sect{ @@ -1454,12 +1455,12 @@ toSection :: Monad m => String -> [String] -> WithCommonOptions CSources CxxSour toSection packageName_ executableNames = go where go (Product CommonOptions{..} a) = do - (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools commonOptionsBuildTools + (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools (unAlias commonOptionsBuildTools) conditionals <- mapM toConditional (fromMaybeList commonOptionsWhen) return Section { sectionData = a - , sectionSourceDirs = nub $ fromMaybeList commonOptionsSourceDirs + , sectionSourceDirs = nub $ fromMaybeList (unAlias commonOptionsSourceDirs) , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions , sectionOtherExtensions = fromMaybeList commonOptionsOtherExtensions , sectionDefaultLanguage = getLast commonOptionsDefaultLanguage @@ -1480,8 +1481,8 @@ toSection packageName_ executableNames = go , sectionInstallIncludes = fromMaybeList commonOptionsInstallIncludes , sectionLdOptions = fromMaybeList commonOptionsLdOptions , sectionBuildable = commonOptionsBuildable - , sectionDependencies = fromMaybe mempty commonOptionsDependencies - , sectionPkgConfigDependencies = fromMaybeList commonOptionsPkgConfigDependencies + , sectionDependencies = fromMaybe mempty (unAlias commonOptionsDependencies) + , sectionPkgConfigDependencies = fromMaybeList (unAlias commonOptionsPkgConfigDependencies) , sectionConditionals = conditionals , sectionBuildTools = buildTools , sectionSystemBuildTools = systemBuildTools <> fromMaybe mempty commonOptionsSystemBuildTools diff --git a/test/Data/Aeson/Config/FromValueSpec.hs b/test/Data/Aeson/Config/FromValueSpec.hs index 585f0ca8..dd6afcb1 100644 --- a/test/Data/Aeson/Config/FromValueSpec.hs +++ b/test/Data/Aeson/Config/FromValueSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} module Data.Aeson.Config.FromValueSpec where import Helper @@ -39,14 +40,26 @@ data FlatMaybe = FlatMaybe { flatMaybeValue :: Maybe String } deriving (Eq, Show, Generic, FromValue) +data AliasMaybe = AliasMaybe { + aliasMaybeValue :: Alias "some-alias" (Maybe String) +} deriving (Eq, Show, Generic, FromValue) + data NestedMaybe = NestedMaybe { nestedMaybeValue :: Maybe (Maybe String) } deriving (Eq, Show, Generic, FromValue) +data AliasNestedMaybe = AliasNestedMaybe { + aliasNestedMaybeValue :: Alias "some-alias" (Maybe (Maybe String)) +} deriving (Eq, Show, Generic, FromValue) + data FlatLast = FlatLast { flatLastValue :: Last String } deriving (Eq, Show, Generic, FromValue) +data AliasLast = AliasLast { + aliasLastValue :: Alias "some-alias" (Last String) +} deriving (Eq, Show, Generic, FromValue) + spec :: Spec spec = do describe "fromValue" $ do @@ -132,6 +145,60 @@ spec = do value: null |] `shouldDecodeTo_` NestedMaybe (Just Nothing) + context "when parsing a field of type (Alias (Maybe a))" $ do + it "accepts a value" $ do + [yaml| + value: some value + |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some value") + + it "allows the field to be accessed by its alias" $ do + [yaml| + some-alias: some alias value + |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some alias value") + + it "gives the primary name precedence" $ do + [yaml| + value: some value + some-alias: some alias value + |] `shouldDecodeTo` Right (AliasMaybe (Alias $ Just "some value"), ["$.some-alias"]) + + it "allows the field to be omitted" $ do + [yaml| + {} + |] `shouldDecodeTo_` AliasMaybe (Alias Nothing) + + it "rejects null" $ do + [yaml| + value: null + |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasMaybe) + + context "when parsing a field of type (Alias (Maybe (Maybe a)))" $ do + it "accepts a value" $ do + [yaml| + value: some value + |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value") + + it "allows the field to be accessed by its alias" $ do + [yaml| + some-alias: some value + |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value") + + it "gives the primary name precedence" $ do + [yaml| + value: some value + some-alias: some alias value + |] `shouldDecodeTo` Right (AliasNestedMaybe (Alias . Just $ Just "some value"), ["$.some-alias"]) + + it "allows the field to be omitted" $ do + [yaml| + {} + |] `shouldDecodeTo_` AliasNestedMaybe (Alias Nothing) + + it "accepts null" $ do + [yaml| + value: null + |] `shouldDecodeTo_` AliasNestedMaybe (Alias $ Just Nothing) + context "when parsing a field of type (Last a)" $ do it "accepts a value" $ do [yaml| @@ -148,6 +215,33 @@ spec = do value: null |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result FlatLast) + context "when parsing a field of type (Alias (Last a))" $ do + it "accepts a value" $ do + [yaml| + value: some value + |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value") + + it "allows the field to be accessed by its alias" $ do + [yaml| + some-alias: some value + |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value") + + it "gives the primary name precedence" $ do + [yaml| + value: some value + some-alias: some alias value + |] `shouldDecodeTo` Right (AliasLast (Alias . Last $ Just "some value"), ["$.some-alias"]) + + it "allows the field to be omitted" $ do + [yaml| + {} + |] `shouldDecodeTo_` AliasLast (Alias $ Last Nothing) + + it "rejects null" $ do + [yaml| + value: null + |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasLast) + context "with (,)" $ do it "captures unrecognized fields" $ do [yaml| diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs index 1567589f..559cb5d9 100644 --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -37,6 +37,13 @@ spec = around_ (inTempDirectoryNamed "foo") $ do library: {} |] `shouldRenderTo` library_ [i| |] + it "warns on duplicate fields" $ do + [i| + name: foo + name: foo + |] `shouldWarn` [ + "package.yaml: Duplicate field $.name" + ] describe "tested-with" $ do it "accepts a string" $ do @@ -60,14 +67,6 @@ spec = around_ (inTempDirectoryNamed "foo") $ do , GHC == 7.4.2 |] - it "warns on duplicate fields" $ do - [i| - name: foo - name: foo - |] `shouldWarn` [ - "package.yaml: Duplicate field $.name" - ] - describe "handling of Paths_ module" $ do it "adds Paths_ to other-modules" $ do [i| @@ -352,6 +351,31 @@ spec = around_ (inTempDirectoryNamed "foo") $ do Foo |] + it "accepts executable defaults" $ do + writeFile "defaults/sol/hpack-template/2017/.hpack/defaults.yaml" [i| + main: Foo.hs + |] + + [i| + executable: + defaults: sol/hpack-template@2017 + |] `shouldRenderTo` executable_ "foo" [i| + main-is: Foo.hs + |] + + it "gives `main` from executable section precedence" $ do + writeFile "defaults/sol/hpack-template/2017/.hpack/defaults.yaml" [i| + main: Foo.hs + |] + + [i| + executable: + main: Bar.hs + defaults: sol/hpack-template@2017 + |] `shouldRenderTo` executable_ "foo" [i| + main-is: Bar.hs + |] + it "accepts a list of defaults" $ do writeFile "defaults/foo/bar/v1/.hpack/defaults.yaml" "default-extensions: RecordWildCards" writeFile "defaults/foo/bar/v2/.hpack/defaults.yaml" "default-extensions: DeriveFunctor" @@ -630,6 +654,16 @@ spec = around_ (inTempDirectoryNamed "foo") $ do packageCabalVersion = "1.12" } + it "accepts build-tool-depends as an alias" $ do + [i| + executable: + build-tool-depends: + hspec-discover: 0.1.0 + |] `shouldRenderTo` (executable_ "foo" [i| + build-tool-depends: + hspec-discover:hspec-discover ==0.1.0 + |]) { packageCabalVersion = "1.12" } + context "when the name of a build tool matches an executable from the same package" $ do it "adds it to build-tools" $ do [i| @@ -735,6 +769,15 @@ spec = around_ (inTempDirectoryNamed "foo") $ do base |] + it "accepts build-depends as an alias" $ do + [i| + executable: + build-depends: base + |] `shouldRenderTo` executable_ "foo" [i| + build-depends: + base + |] + it "accepts dependencies with subcomponents" $ do [i| executable: @@ -795,6 +838,18 @@ spec = around_ (inTempDirectoryNamed "foo") $ do , weston |] + it "accepts pkgconfig-depends as an alias" $ do + [i| + pkgconfig-depends: + - QtWebKit + - weston + executable: {} + |] `shouldRenderTo` executable_ "foo" [i| + pkgconfig-depends: + QtWebKit + , weston + |] + describe "include-dirs" $ do it "accepts include-dirs" $ do [i| @@ -1508,6 +1563,14 @@ spec = around_ (inTempDirectoryNamed "foo") $ do |] describe "executables" $ do + it "accepts main-is as an alias for main" $ do + [i| + executable: + main-is: Foo.hs + |] `shouldRenderTo` executable_ "foo" [i| + main-is: Foo.hs + |] + it "accepts arbitrary entry points as main" $ do touch "src/Foo.hs" touch "src/Bar.hs" diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs index 25f056b5..3623ebd2 100644 --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -425,6 +425,15 @@ spec = do |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) + it "accepts hs-source-dirs as an alias for source-dirs" $ do + withPackageConfig_ [i| + library: + hs-source-dirs: + - foo + - bar + |] + (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) + it "accepts default-extensions" $ do withPackageConfig_ [i| library: