Skip to content

Commit

Permalink
Accept .cabal aliases for fields where hpack and .cabal differ
Browse files Browse the repository at this point in the history 
- `main-is` as an alias for `main`
- `hs-source-dirs` as an alias for `source-dirs`
- `build-depends` as an alias for `dependencies`
- `pkgconfig-depends` as an alias for `pkg-config-dependencies`
- `build-tool-depends` as an alias for `build-tools`
  • Loading branch information
@sol
sol committed Apr 22, 2022
1 parent e8ae383 commit 92c6c94
Show file tree
Hide file tree
Showing 5 changed files with 223 additions and 27 deletions.
29 changes: 29 additions & 0 deletions src/Data/Aeson/Config/FromValue.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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(..))
Expand Down Expand Up @@ -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
39 changes: 20 additions & 19 deletions src/Hpack/Config.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
}
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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
}
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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{
Expand All @@ -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
Expand All @@ -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
Expand Down
94 changes: 94 additions & 0 deletions test/Data/Aeson/Config/FromValueSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
module Data.Aeson.Config.FromValueSpec where

import Helper
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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|
Expand All @@ -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|
Expand Down
Loading

0 comments on commit 92c6c94

Please sign in to comment.