{-# LANGUAGE LambdaCase #-}
module Distribution.Client.Init.FlagExtractors
(
getPackageDir
, getSimpleProject
, getMinimal
, getCabalVersion
, getCabalVersionNoPrompt
, getPackageName
, getVersion
, getLicense
, getAuthor
, getEmail
, getHomepage
, getSynopsis
, getCategory
, getExtraSrcFiles
, getExtraDocFiles
, getPackageType
, getMainFile
, getInitializeTestSuite
, getTestDirs
, getLanguage
, getNoComments
, getAppDirs
, getSrcDirs
, getExposedModules
, getBuildTools
, getDependencies
, getOtherExts
, getOverwrite
, getOtherModules
, simpleProjectPrompt
, initializeTestSuitePrompt
, packageTypePrompt
, testMainPrompt
, dependenciesPrompt
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last)
import qualified Data.List.NonEmpty as NEL
import Distribution.CabalSpecVersion (CabalSpecVersion(..))
import Distribution.Version (Version)
import Distribution.ModuleName (ModuleName)
import Distribution.Types.Dependency (Dependency(..))
import Distribution.Types.PackageName (PackageName)
import Distribution.Client.Init.Defaults
import Distribution.FieldGrammar.Newtypes (SpecLicense)
import Distribution.Client.Init.Types
import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe)
import Distribution.Simple.Flag (flagElim)
import Language.Haskell.Extension (Language(..), Extension(..))
import Distribution.Client.Init.Prompt
import qualified Data.Set as Set
import Distribution.Simple.PackageIndex
import Distribution.Client.Init.Utils
getPackageDir :: Interactive m => InitFlags -> m FilePath
getPackageDir :: forall (m :: * -> *). Interactive m => InitFlags -> m FilePath
getPackageDir = forall b a. b -> (a -> b) -> Flag a -> b
flagElim forall (m :: * -> *). Interactive m => m FilePath
getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag FilePath
packageDir
getSimpleProject :: Interactive m => InitFlags -> m Bool -> m Bool
getSimpleProject :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m Bool -> m Bool
getSimpleProject InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag Bool
simpleProject InitFlags
flags)
getMinimal :: Interactive m => InitFlags -> m Bool
getMinimal :: forall (m :: * -> *). Interactive m => InitFlags -> m Bool
getMinimal = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag Bool
minimal
getCabalVersion :: Interactive m => InitFlags -> m CabalSpecVersion -> m CabalSpecVersion
getCabalVersion :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m CabalSpecVersion -> m CabalSpecVersion
getCabalVersion InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag CabalSpecVersion
cabalVersion InitFlags
flags)
getCabalVersionNoPrompt :: InitFlags -> CabalSpecVersion
getCabalVersionNoPrompt :: InitFlags -> CabalSpecVersion
getCabalVersionNoPrompt = forall a. a -> Flag a -> a
fromFlagOrDefault CabalSpecVersion
defaultCabalVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag CabalSpecVersion
cabalVersion
getPackageName :: Interactive m => InitFlags -> m PackageName -> m PackageName
getPackageName :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m PackageName -> m PackageName
getPackageName InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag PackageName
packageName InitFlags
flags)
getVersion :: Interactive m => InitFlags -> m Version -> m Version
getVersion :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m Version -> m Version
getVersion InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag Version
version InitFlags
flags)
getLicense :: Interactive m => InitFlags -> m SpecLicense -> m SpecLicense
getLicense :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m SpecLicense -> m SpecLicense
getLicense InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag SpecLicense
license InitFlags
flags)
getAuthor :: Interactive m => InitFlags -> m String -> m String
getAuthor :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m FilePath -> m FilePath
getAuthor InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag FilePath
author InitFlags
flags)
getEmail :: Interactive m => InitFlags -> m String -> m String
getEmail :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m FilePath -> m FilePath
getEmail InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag FilePath
email InitFlags
flags)
getHomepage :: Interactive m => InitFlags -> m String -> m String
getHomepage :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m FilePath -> m FilePath
getHomepage InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag FilePath
homepage InitFlags
flags)
getSynopsis :: Interactive m => InitFlags -> m String -> m String
getSynopsis :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m FilePath -> m FilePath
getSynopsis InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag FilePath
synopsis InitFlags
flags)
getCategory :: Interactive m => InitFlags -> m String -> m String
getCategory :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m FilePath -> m FilePath
getCategory InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag FilePath
category InitFlags
flags)
getExtraSrcFiles :: Interactive m => InitFlags -> m (Set String)
= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Flag a -> b
flagElim forall a. Monoid a => a
mempty forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [FilePath]
extraSrc
getExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set String))
= forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Flag a -> b
flagElim (forall a. a -> Set a
Set.singleton FilePath
defaultChangelog) forall a. Ord a => [a] -> Set a
Set.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [FilePath]
extraDoc
getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType
getPackageType :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m PackageType -> m PackageType
getPackageType InitFlags
{ initializeTestSuite :: InitFlags -> Flag Bool
initializeTestSuite = Flag Bool
True
, packageType :: InitFlags -> Flag PackageType
packageType = Flag PackageType
NoFlag
} m PackageType
_ = forall (m :: * -> *) a. Monad m => a -> m a
return PackageType
TestSuite
getPackageType InitFlags
flags m PackageType
act = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag PackageType
packageType InitFlags
flags) m PackageType
act
getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath
getMainFile :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m HsFilePath -> m HsFilePath
getMainFile InitFlags
flags m HsFilePath
act = case InitFlags -> Flag FilePath
mainIs InitFlags
flags of
Flag FilePath
a
| FilePath -> Bool
isHsFilePath FilePath
a -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> HsFilePath
toHsFilePath FilePath
a
| Bool
otherwise -> m HsFilePath
act
Flag FilePath
NoFlag -> m HsFilePath
act
getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool
getInitializeTestSuite :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m Bool -> m Bool
getInitializeTestSuite InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag Bool
initializeTestSuite InitFlags
flags)
getTestDirs :: Interactive m => InitFlags -> m [String] -> m [String]
getTestDirs :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m [FilePath] -> m [FilePath]
getTestDirs InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag [FilePath]
testDirs InitFlags
flags)
getLanguage :: Interactive m => InitFlags -> m Language -> m Language
getLanguage :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m Language -> m Language
getLanguage InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag Language
language InitFlags
flags)
getNoComments :: Interactive m => InitFlags -> m Bool -> m Bool
InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag Bool
noComments InitFlags
flags)
getAppDirs :: Interactive m => InitFlags -> m [String] -> m [String]
getAppDirs :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m [FilePath] -> m [FilePath]
getAppDirs InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag [FilePath]
applicationDirs InitFlags
flags)
getSrcDirs :: Interactive m => InitFlags -> m [String] -> m [String]
getSrcDirs :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m [FilePath] -> m [FilePath]
getSrcDirs InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag [FilePath]
sourceDirs InitFlags
flags)
getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName)
getExposedModules :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m (NonEmpty ModuleName)
getExposedModules = forall (m :: * -> *) a. Monad m => a -> m a
return
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (ModuleName
myLibModule forall a. a -> [a] -> NonEmpty a
NEL.:| [])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Flag a -> Maybe a
flagToMaybe
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [ModuleName]
exposedModules
getOtherModules :: Interactive m => InitFlags -> m [ModuleName]
getOtherModules :: forall (m :: * -> *). Interactive m => InitFlags -> m [ModuleName]
getOtherModules = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flag a -> a
fromFlagOrDefault [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [ModuleName]
otherModules
getBuildTools :: Interactive m => InitFlags -> m [Dependency]
getBuildTools :: forall (m :: * -> *). Interactive m => InitFlags -> m [Dependency]
getBuildTools = forall b a. b -> (a -> b) -> Flag a -> b
flagElim (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {a} {m :: * -> *}.
(Parsec a, Interactive m) =>
[a] -> FilePath -> m [a]
go []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [FilePath]
buildTools
where
go :: [a] -> FilePath -> m [a]
go [a]
acc FilePath
dep = case forall a. Parsec a => FilePath -> Either FilePath a
eitherParsec FilePath
dep of
Left FilePath
e -> do
forall (m :: * -> *). Interactive m => FilePath -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse dependency: " forall a. [a] -> [a] -> [a]
++ FilePath
e
forall (m :: * -> *). Interactive m => FilePath -> m ()
putStrLn FilePath
"Skipping..."
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
Right a
d -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a]
acc forall a. [a] -> [a] -> [a]
++ [a
d]
getDependencies
:: Interactive m
=> InitFlags
-> m [Dependency]
-> m [Dependency]
getDependencies :: forall (m :: * -> *).
Interactive m =>
InitFlags -> m [Dependency] -> m [Dependency]
getDependencies InitFlags
flags = forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt (InitFlags -> Flag [Dependency]
dependencies InitFlags
flags)
getOtherExts :: Interactive m => InitFlags -> m [Extension]
getOtherExts :: forall (m :: * -> *). Interactive m => InitFlags -> m [Extension]
getOtherExts = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flag a -> a
fromFlagOrDefault [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag [Extension]
otherExts
getOverwrite :: Interactive m => InitFlags -> m Bool
getOverwrite :: forall (m :: * -> *). Interactive m => InitFlags -> m Bool
getOverwrite = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitFlags -> Flag Bool
overwrite
simpleProjectPrompt :: Interactive m => InitFlags -> m Bool
simpleProjectPrompt :: forall (m :: * -> *). Interactive m => InitFlags -> m Bool
simpleProjectPrompt InitFlags
flags = forall (m :: * -> *).
Interactive m =>
InitFlags -> m Bool -> m Bool
getSimpleProject InitFlags
flags forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
Interactive m =>
FilePath -> DefaultPrompt Bool -> m Bool
promptYesNo
FilePath
"Should I generate a simple project with sensible defaults"
(forall t. t -> DefaultPrompt t
DefaultPrompt Bool
True)
initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool
initializeTestSuitePrompt :: forall (m :: * -> *). Interactive m => InitFlags -> m Bool
initializeTestSuitePrompt InitFlags
flags = forall (m :: * -> *).
Interactive m =>
InitFlags -> m Bool -> m Bool
getInitializeTestSuite InitFlags
flags forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
Interactive m =>
FilePath -> DefaultPrompt Bool -> m Bool
promptYesNo
FilePath
"Should I generate a test suite for the library"
(forall t. t -> DefaultPrompt t
DefaultPrompt Bool
True)
packageTypePrompt :: Interactive m => InitFlags -> m PackageType
packageTypePrompt :: forall (m :: * -> *). Interactive m => InitFlags -> m PackageType
packageTypePrompt InitFlags
flags = forall (m :: * -> *).
Interactive m =>
InitFlags -> m PackageType -> m PackageType
getPackageType InitFlags
flags forall a b. (a -> b) -> a -> b
$ do
FilePath
pt <- forall (m :: * -> *).
Interactive m =>
FilePath
-> [FilePath]
-> DefaultPrompt FilePath
-> Maybe (FilePath -> FilePath)
-> Bool
-> m FilePath
promptList FilePath
"What does the package build"
[FilePath]
packageTypes
(forall t. t -> DefaultPrompt t
DefaultPrompt FilePath
"Executable")
forall a. Maybe a
Nothing
Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe PackageType
Executable (FilePath -> Maybe PackageType
parsePackageType FilePath
pt)
where
packageTypes :: [FilePath]
packageTypes =
[ FilePath
"Library"
, FilePath
"Executable"
, FilePath
"Library and Executable"
, FilePath
"Test suite"
]
parsePackageType :: FilePath -> Maybe PackageType
parsePackageType = \case
FilePath
"Library" -> forall a. a -> Maybe a
Just PackageType
Library
FilePath
"Executable" -> forall a. a -> Maybe a
Just PackageType
Executable
FilePath
"Library and Executable" -> forall a. a -> Maybe a
Just PackageType
LibraryAndExecutable
FilePath
"Test suite" -> forall a. a -> Maybe a
Just PackageType
TestSuite
FilePath
_ -> forall a. Maybe a
Nothing
testMainPrompt :: Interactive m => m HsFilePath
testMainPrompt :: forall (m :: * -> *). Interactive m => m HsFilePath
testMainPrompt = do
FilePath
fp <- forall (m :: * -> *).
Interactive m =>
FilePath
-> [FilePath]
-> DefaultPrompt FilePath
-> Maybe (FilePath -> FilePath)
-> Bool
-> m FilePath
promptList FilePath
"What is the main module of the test suite?"
[FilePath
defaultMainIs', FilePath
"Main.lhs"]
(forall t. t -> DefaultPrompt t
DefaultPrompt FilePath
defaultMainIs')
forall a. Maybe a
Nothing
Bool
True
let hs :: HsFilePath
hs = FilePath -> HsFilePath
toHsFilePath FilePath
fp
case HsFilePath -> HsFileType
_hsFileType HsFilePath
hs of
HsFileType
InvalidHsPath -> do
forall (m :: * -> *). Interactive m => FilePath -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
"Main file "
, forall a. Show a => a -> FilePath
show HsFilePath
hs
, FilePath
" is not a valid haskell file. Source files must end in .hs or .lhs."
]
forall (m :: * -> *). Interactive m => m HsFilePath
testMainPrompt
HsFileType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return HsFilePath
hs
where
defaultMainIs' :: FilePath
defaultMainIs' = forall a. Show a => a -> FilePath
show HsFilePath
defaultMainIs
dependenciesPrompt
:: Interactive m
=> InstalledPackageIndex
-> InitFlags
-> m [Dependency]
dependenciesPrompt :: forall (m :: * -> *).
Interactive m =>
InstalledPackageIndex -> InitFlags -> m [Dependency]
dependenciesPrompt InstalledPackageIndex
pkgIx InitFlags
flags = forall (m :: * -> *).
Interactive m =>
InitFlags -> m [Dependency] -> m [Dependency]
getDependencies InitFlags
flags (forall (m :: * -> *).
Interactive m =>
InstalledPackageIndex -> InitFlags -> m [Dependency]
getBaseDep InstalledPackageIndex
pkgIx InitFlags
flags)
fromFlagOrPrompt
:: Interactive m
=> Flag a
-> m a
-> m a
fromFlagOrPrompt :: forall (m :: * -> *) a. Interactive m => Flag a -> m a -> m a
fromFlagOrPrompt Flag a
flag m a
action = forall b a. b -> (a -> b) -> Flag a -> b
flagElim m a
action forall (m :: * -> *) a. Monad m => a -> m a
return Flag a
flag