module Staversion.Internal.Command
( Command(..),
parseCommandArgs,
defFormatConfig,
_parseCommandStrings
) where
import Control.Applicative ((<$>), (<*>), optional, some, (<|>), many)
import Data.Function (on)
import Data.Monoid (mconcat, (<>))
import Data.Text (pack)
import qualified Options.Applicative as Opt
import qualified Paths_staversion as MyInfo
import System.Directory (getHomeDirectory)
import System.FilePath ((</>))
import qualified Text.PrettyPrint.ANSI.Leijen as Pretty
import Staversion.Internal.Aggregate (Aggregator)
import qualified Staversion.Internal.Aggregate as Agg
import Staversion.Internal.Format (FormatConfig(..), FormatVersion)
import qualified Staversion.Internal.Format as Format
import Staversion.Internal.Log
( LogLevel(..), Logger(loggerThreshold), defaultLogger
)
import Staversion.Internal.Query
( Resolver,
PackageName,
Query(..),
parseQuery,
PackageSource(..)
)
import Staversion.Internal.Version (showBaseVersion)
data Command =
Command { commBuildPlanDir :: FilePath,
commStackCommand :: String,
commLogger :: Logger,
commSources :: [PackageSource],
commQueries :: [Query],
commAllowNetwork :: Bool,
commAggregator :: Maybe Aggregator,
commFormatConfig :: FormatConfig
}
data DefCommand = DefCommand { defBuildPlanDir :: FilePath
} deriving (Show,Eq,Ord)
defCommand :: IO DefCommand
defCommand = DefCommand <$> def_build_plan_dir where
def_build_plan_dir = do
home <- getHomeDirectory
return $ home </> ".stack" </> "build-plan"
commandParser :: DefCommand -> Opt.Parser Command
commandParser def_comm = Command <$> build_plan_dir <*> stack_command <*> logger <*> sources
<*> queries <*> network <*> aggregate <*> format_config where
logger = makeLogger <$> is_verbose
makeLogger True = defaultLogger { loggerThreshold = Just LogDebug }
makeLogger False = defaultLogger
is_verbose = Opt.switch $ mconcat [ Opt.long "verbose",
Opt.short 'v',
Opt.help "Verbose messages."
]
build_plan_dir = Opt.strOption
$ mconcat [ Opt.long "build-plan-dir",
Opt.help "Directory where build plan YAML files are stored.",
Opt.metavar "DIR",
Opt.value (defBuildPlanDir def_comm),
Opt.showDefault
]
withDefault :: Functor m => [a] -> m [a] -> m [a]
withDefault def_vals = fmap applyDef
where
applyDef [] = def_vals
applyDef vs = vs
sources = withDefault [SourceStackDefault] $ many $ resolver <|> hackage <|> stack_explicit <|> stack_default
resolver = fmap SourceStackage $ Opt.strOption
$ mconcat [ Opt.long "resolver",
Opt.short 'r',
Opt.help "Stackage resolver to search. e.g. \"lts-6.15\"",
Opt.metavar "RESOLVER_NAME"
]
hackage = Opt.flag' SourceHackage
$ mconcat [ Opt.long "hackage",
Opt.short 'H',
Opt.help "Search hackage.org for the latest version."
]
stack_explicit = fmap SourceStackYaml $ Opt.strOption
$ mconcat [ Opt.long "stack",
Opt.help ( "Path to stack.yaml file."
++ " It searches for package versions of the resolver of the specified stack.yaml file."
),
Opt.metavar "FILE"
]
stack_default = Opt.flag' SourceStackDefault
$ mconcat [ Opt.long "stack-default",
Opt.short 'S',
Opt.help ( "Search the resolver that 'stack' command would use by default."
++ " This option is implied if there is no options about package source (e.g. -r and -H)."
)
]
queries = withDefault [QueryStackYamlDefault] $ many $ parseQuery <$> (query_package <|> query_cabal <|> query_stack_yaml)
query_package = Opt.strArgument
$ mconcat [ Opt.help "Name of package whose version you want to check.",
Opt.metavar "PACKAGE_NAME"
]
query_cabal = Opt.strArgument
$ mconcat [ Opt.help ".cabal file name. It checks versions of packages in build-deps lists.",
Opt.metavar "CABAL_FILEPATH"
]
query_stack_yaml = Opt.strArgument
$ mconcat [ Opt.help ( "Path to stack.yaml file."
++ " It checks versions of packages in build-deps of all cabal projects listed in the stack.yaml."
++ " If you just type 'stack.yaml',"
++ " it means the default configuration that 'stack' command would use by default."
++ " 'stack.yaml' is implied if there is no query argument."
),
Opt.metavar "STACK_YAML_FILEPATH"
]
network = not <$> no_network
no_network = Opt.switch $ mconcat [ Opt.long "no-network",
Opt.help "Forbid network access."
]
aggregate = optional $ Opt.option (maybeReader "AGGREGATOR" parseAggregator)
$ mconcat [ Opt.long "aggregate",
Opt.short 'a',
Opt.metavar "AGGREGATOR",
Opt.helpDoc $ Just $ docAggregators "AGGREGATOR"
]
format_config = FormatConfig <$> format_version
format_version = Opt.option (maybeReader "FORMAT" $ parseSelect formatVersions)
$ mconcat [ Opt.long "format-version",
Opt.metavar "FORMAT",
Opt.helpDoc $ Just $ docFormatVersions "FORMAT",
Opt.value $ fconfFormatVersion defFormatConfig
]
stack_command = Opt.strOption
$ mconcat [ Opt.long "stack-command",
Opt.help "Shell command for stack tool.",
Opt.metavar "COMMAND",
Opt.value "stack",
Opt.showDefault
]
maybeReader :: String -> (String -> Maybe a) -> Opt.ReadM a
maybeReader metavar mfunc = do
got <- Opt.str
case mfunc got of
Nothing -> Opt.readerError ("Unknown " ++ metavar ++ ": " ++ got)
Just v -> return v
data SelectSpec a = SelectSpec { selectResult :: a,
selectSymbol :: String,
selectDesc :: String
}
type AggregatorSpec = SelectSpec Aggregator
aggregators :: [AggregatorSpec]
aggregators = [ SelectSpec Agg.aggOr "or" "concatenate versions with (||).",
SelectSpec Agg.aggPvpMajor "pvp-major"
( "aggregate versions to a range that is supposed to be "
++ "compatible with the given versions "
++ "in terms of PVP (Package Versioning Policy.) "
++ "Major versions are used for upper bounds."
),
SelectSpec Agg.aggPvpMajor "pvp" "alias for 'pvp-major'",
SelectSpec Agg.aggPvpMinor "pvp-minor"
( "aggregate versions to a range that is supposed to be "
++ "compatible with the given versions "
++ "in terms of PVP. "
++ "Minor versions are used for upper bounds, i.e. this is stricter than 'pvp-major'."
)
]
parseSelect :: [SelectSpec a] -> String -> Maybe a
parseSelect specs symbol = toMaybe $ filter (\spec -> selectSymbol spec == symbol) specs where
toMaybe [] = Nothing
toMaybe (spec : _) = Just $ selectResult spec
parseAggregator :: String -> Maybe Aggregator
parseAggregator = parseSelect aggregators
wrapped :: String -> Pretty.Doc
wrapped = Pretty.fillSep . map Pretty.text . words
docSelect :: [SelectSpec a] -> String -> String -> Pretty.Doc
docSelect specs foreword_str metavar = Pretty.vsep $ (foreword :) $ map docSpec specs where
foreword = wrapped ( foreword_str ++ " Possible " ++ metavar ++ " is:" )
docSpec SelectSpec {selectSymbol = symbol, selectDesc = desc} =
Pretty.hang 2 $ wrapped (symbol <> ": " <> desc)
docSelectWithDefault :: [SelectSpec a] -> String -> String -> Pretty.Doc
docSelectWithDefault [] foreword metavar = docSelect [] foreword metavar where
docSelectWithDefault (def_spec : rest) foreword metavar = docSelect (def_spec' : rest) foreword metavar where
def_spec' = def_spec { selectSymbol = selectSymbol def_spec <> " [DEFAULT]" }
docAggregators :: String -> Pretty.Doc
docAggregators = docSelect aggregators "Aggregate version results over different resolvers."
defFormatConfig :: FormatConfig
defFormatConfig = FormatConfig { fconfFormatVersion = selectResult $ head formatVersions
}
formatVersions :: [SelectSpec FormatVersion]
formatVersions = [ SelectSpec Format.formatVersionCabal "cabal"
( "Let Cabal format VersionRanges"
),
SelectSpec Format.formatVersionCabalCaret "cabal-caret"
( "Similar to 'cabal', but it uses the caret operator (^>=) if possible"
)
]
docFormatVersions :: String -> Pretty.Doc
docFormatVersions = docSelectWithDefault formatVersions "Format for package version ranges."
programDescription :: Opt.Parser a -> Opt.ParserInfo a
programDescription parser =
Opt.info (Opt.helper <*> parser)
$ mconcat [ Opt.fullDesc,
Opt.progDesc ( "Look for version numbers for Haskell packages in specific stackage resolvers"
++ " (or possibly other package sources)"
),
Opt.footer ("Version: " ++ (showBaseVersion MyInfo.version))
]
parseCommandArgs :: IO Command
parseCommandArgs = Opt.execParser . programDescription . commandParser =<< defCommand
_parseCommandStrings :: [String] -> IO (Maybe Command)
_parseCommandStrings args = fmap (doParse . programDescription . commandParser) defCommand
where
doParse pinfo = Opt.getParseResult $ Opt.execParserPure prefs pinfo args
prefs = Opt.prefs mempty