{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.GenericPackageDescription (
GenericPackageDescription(..),
emptyGenericPackageDescription,
Flag(..),
emptyFlag,
FlagName,
mkFlagName,
unFlagName,
FlagAssignment,
mkFlagAssignment,
unFlagAssignment,
lookupFlagAssignment,
insertFlagAssignment,
diffFlagAssignment,
findDuplicateFlagAssignments,
nullFlagAssignment,
showFlagValue,
dispFlagAssignment,
parseFlagAssignment,
parsecFlagAssignment,
ConfVar(..),
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Distribution.Utils.Generic (lowercase)
import qualified Text.PrettyPrint as Disp
import qualified Data.Map as Map
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.Compat.CharParsing as P
import Distribution.Compat.ReadP ((+++))
import Distribution.Compat.Lens as L
import qualified Distribution.Types.BuildInfo.Lens as L
import Distribution.Types.PackageDescription
import Distribution.Types.Dependency
import Distribution.Types.Library
import Distribution.Types.ForeignLib
import Distribution.Types.Executable
import Distribution.Types.TestSuite
import Distribution.Types.Benchmark
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.Package
import Distribution.Version
import Distribution.Compiler
import Distribution.System
import Distribution.Parsec.Class
import Distribution.Pretty
import Distribution.Text
data GenericPackageDescription =
GenericPackageDescription
{ packageDescription :: PackageDescription
, genPackageFlags :: [Flag]
, condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
, condSubLibraries :: [( UnqualComponentName
, CondTree ConfVar [Dependency] Library )]
, condForeignLibs :: [( UnqualComponentName
, CondTree ConfVar [Dependency] ForeignLib )]
, condExecutables :: [( UnqualComponentName
, CondTree ConfVar [Dependency] Executable )]
, condTestSuites :: [( UnqualComponentName
, CondTree ConfVar [Dependency] TestSuite )]
, condBenchmarks :: [( UnqualComponentName
, CondTree ConfVar [Dependency] Benchmark )]
}
deriving (Show, Eq, Typeable, Data, Generic)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
instance Binary GenericPackageDescription
instance NFData GenericPackageDescription where rnf = genericRnf
emptyGenericPackageDescription :: GenericPackageDescription
emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
instance L.HasBuildInfos GenericPackageDescription where
traverseBuildInfos f (GenericPackageDescription p a1 x1 x2 x3 x4 x5 x6) =
GenericPackageDescription
<$> L.traverseBuildInfos f p
<*> pure a1
<*> (traverse . traverse . L.buildInfo) f x1
<*> (traverse . L._2 . traverse . L.buildInfo) f x2
<*> (traverse . L._2 . traverse . L.buildInfo) f x3
<*> (traverse . L._2 . traverse . L.buildInfo) f x4
<*> (traverse . L._2 . traverse . L.buildInfo) f x5
<*> (traverse . L._2 . traverse . L.buildInfo) f x6
data Flag = MkFlag
{ flagName :: FlagName
, flagDescription :: String
, flagDefault :: Bool
, flagManual :: Bool
}
deriving (Show, Eq, Typeable, Data, Generic)
instance Binary Flag
instance NFData Flag where rnf = genericRnf
emptyFlag :: FlagName -> Flag
emptyFlag name = MkFlag
{ flagName = name
, flagDescription = ""
, flagDefault = True
, flagManual = False
}
newtype FlagName = FlagName ShortText
deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData)
mkFlagName :: String -> FlagName
mkFlagName = FlagName . toShortText
instance IsString FlagName where
fromString = mkFlagName
unFlagName :: FlagName -> String
unFlagName (FlagName s) = fromShortText s
instance Binary FlagName
instance Pretty FlagName where
pretty = Disp.text . unFlagName
instance Parsec FlagName where
parsec = mkFlagName . lowercase <$> parsec'
where
parsec' = (:) <$> lead <*> rest
lead = P.satisfy (\c -> isAlphaNum c || c == '_')
rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
instance Text FlagName where
parse = mkFlagName . lowercase <$> parse'
where
parse' = (:) <$> lead <*> rest
lead = Parse.satisfy (\c -> isAlphaNum c || c == '_')
rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')
newtype FlagAssignment
= FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) }
deriving (Binary, Generic, NFData)
instance Eq FlagAssignment where
(==) (FlagAssignment m1) (FlagAssignment m2)
= fmap snd m1 == fmap snd m2
instance Ord FlagAssignment where
compare (FlagAssignment m1) (FlagAssignment m2)
= fmap snd m1 `compare` fmap snd m2
combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2)
instance Semigroup FlagAssignment where
(<>) (FlagAssignment m1) (FlagAssignment m2)
= FlagAssignment (Map.unionWith combineFlagValues m1 m2)
instance Monoid FlagAssignment where
mempty = FlagAssignment Map.empty
mappend = (<>)
mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment =
FlagAssignment .
Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b)))
unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment
nullFlagAssignment :: FlagAssignment -> Bool
nullFlagAssignment = Map.null . getFlagAssignment
lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool
lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment
insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment
insertFlagAssignment flag val =
FlagAssignment .
Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment
diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
diffFlagAssignment fa1 fa2 = FlagAssignment
(Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2))
findDuplicateFlagAssignments :: FlagAssignment -> [FlagName]
findDuplicateFlagAssignments =
Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment
instance Read FlagAssignment where
readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ]
instance Show FlagAssignment where
showsPrec p (FlagAssignment xs) = showsPrec p xs
showFlagValue :: (FlagName, Bool) -> String
showFlagValue (f, True) = '+' : unFlagName f
showFlagValue (f, False) = '-' : unFlagName f
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment
parsecFlagAssignment :: ParsecParser FlagAssignment
parsecFlagAssignment = mkFlagAssignment <$>
P.sepBy (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
_ <- P.optional (P.char '+')
f <- parsec
return (f, True)
offFlag = do
_ <- P.char '-'
f <- parsec
return (f, False)
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = mkFlagAssignment <$>
Parse.sepBy parseFlagValue Parse.skipSpaces1
where
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parse
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parse
return (f, False))
data ConfVar = OS OS
| Arch Arch
| Flag FlagName
| Impl CompilerFlavor VersionRange
deriving (Eq, Show, Typeable, Data, Generic)
instance Binary ConfVar
instance NFData ConfVar where rnf = genericRnf