ats-pkg-2.6.1.1: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main ( main
            ) where

import           Control.Composition
import           Control.Lens               hiding (List, argument)
import           Data.Bool                  (bool)
import           Data.Maybe                 (fromMaybe)
import           Data.Semigroup             (Semigroup (..))
import qualified Data.Text.Lazy             as TL
import           Data.Version               hiding (Version (..))
import           Development.Shake.ATS
import           Development.Shake.FilePath
import           Language.ATS.Package
import           Options.Applicative
import qualified Paths_ats_pkg              as P
import           System.Directory
import           System.IO.Temp             (withSystemTempDirectory)

-- TODO command to list available packages.
wrapper :: ParserInfo Command
wrapper = info (helper <*> versionInfo <*> command')
    (fullDesc
    <> progDesc "The atspkg build tool for ATS-Postiats."
    <> header "atspkg - a build tool for ATS\nsee 'man atspkg' for more detailed help")

versionInfo :: Parser (a -> a)
versionInfo = infoOption ("atspkg version: " ++ showVersion P.version) (short 'V' <> long "version" <> help "Show version")

data Command = Install
             | Build { _targets    :: [String]
                     , _archTarget :: Maybe String
                     , _rebuildAll :: Bool
                     , _verbosity  :: Int
                     , _lint       :: Bool
                     }
             | Clean
             | Test { _targets    :: [String]
                    , _rebuildAll :: Bool
                    , _lint       :: Bool
                    }
             | Fetch { _url :: String }
             | Nuke
             | Upgrade
             | Valgrind { _targets :: [String] }
             | Run { _targets    :: [String]
                   , _rebuildAll :: Bool
                   , _lint       :: Bool
                   }
             | Check { _filePath :: String, _details :: Bool }
             | List

command' :: Parser Command
command' = hsubparser
    (command "install" (info (pure Install) (progDesc "Install all binaries to $HOME/.local/bin"))
    <> command "clean" (info (pure Clean) (progDesc "Clean current project directory"))
    <> command "remote" (info fetch (progDesc "Fetch and install a binary package"))
    <> command "build" (info build' (progDesc "Build current package targets"))
    <> command "test" (info test' (progDesc "Test current package"))
    <> command "nuke" (info (pure Nuke) (progDesc "Uninstall all globally installed libraries"))
    <> command "upgrade" (info (pure Upgrade) (progDesc "Upgrade to the latest version of atspkg"))
    <> command "valgrind" (info valgrind (progDesc "Run generated binaries through valgrind"))
    <> command "run" (info run' (progDesc "Run generated binaries"))
    <> command "check" (info check' (progDesc "Audit a package set to ensure it is well-typed."))
    <> command "list" (info (pure List) (progDesc "List available packages"))
    )

check' :: Parser Command
check' = Check
    <$> targetP dhallCompletions id "check"
    <*> switch
    (long "detailed"
    <> short 'd'
    <> help "Enable detailed error messages")

ftypeCompletions :: String -> Mod ArgumentFields a
ftypeCompletions ext = completer . bashCompleter $ "file -X '!*." ++ ext ++ "' -o plusdirs"

dhallCompletions :: Mod ArgumentFields a
dhallCompletions = ftypeCompletions "dhall"

run' :: Parser Command
run' = Run <$> targets "run"
    <*> rebuild
    <*> noLint

test' :: Parser Command
test' = Test
    <$> targets "test"
    <*> rebuild
    <*> noLint

valgrind :: Parser Command
valgrind = Valgrind <$> targets "run with valgrind"

targets :: String -> Parser [String]
targets = targetP mempty many

targetP :: Mod ArgumentFields String -> (Parser String -> a) -> String -> a
targetP completions' f s = f
    (argument str
    (metavar "TARGET"
    <> help ("Targets to " <> s)
    <> completions'))

rebuild :: Parser Bool
rebuild = switch
    (long "rebuild"
    <> short 'r'
    <> help "Force rebuild of all targets")

triple :: Parser (Maybe String)
triple = optional
    (strOption
    (long "target"
    <> short 't'
    <> help "Set target by using its triple"))

verbosity :: Parser Int
verbosity = length <$>
    many (flag' () (short 'v' <> long "verbose" <> help "Turn up verbosity"))

build' :: Parser Command
build' = Build
    <$> targets "build"
    <*> triple
    <*> rebuild
    <*> verbosity
    <*> noLint

noLint :: Parser Bool
noLint = fmap not
    (switch
    (long "no-lint"
    <> short 'l'
    <> help "Disable the shake linter"))

fetch :: Parser Command
fetch = Fetch <$>
    argument str
    (metavar "URL"
    <> help "URL pointing to a tarball containing the package to be installed.")

fetchPkg :: String -> IO ()
fetchPkg pkg = withSystemTempDirectory "atspkg" $ \p -> do
    let (lib, dirName, url') = (mempty, p, pkg) & each %~ TL.pack
    buildHelper True (ATSDependency lib dirName url' undefined undefined mempty mempty)
    ps <- getSubdirs p
    pkgDir <- fromMaybe p <$> findFile (p:ps) "atspkg.dhall"
    let a = withCurrentDirectory (takeDirectory pkgDir) (mkPkg False False mempty ["install"] Nothing 0)
    bool (buildAll (Just pkgDir) >> a) a =<< check (Just pkgDir)

main :: IO ()
main = execParser wrapper >>= run

runHelper :: Bool -> Bool -> [String] -> Maybe String -> Int -> IO ()
runHelper rba lint rs tgt v = g . bool x y =<< check Nothing
    where g xs = mkPkg rba lint xs rs tgt v
          y = mempty
          x = [buildAll Nothing]

run :: Command -> IO ()
run List = displayList "https://raw.githubusercontent.com/vmchale/atspkg/master/pkgs/pkg-set.dhall"
run (Check p b) = print =<< checkPkg p b
run Upgrade = upgradeBin "vmchale" "atspkg"
run Nuke = cleanAll
run (Fetch u) = fetchPkg u
run Clean = mkPkg False True mempty ["clean"] Nothing 0
run (Build rs tgt rba v lint) = runHelper rba lint rs tgt v
run (Test ts rba lint) = runHelper rba lint ("test" : ts) Nothing 0
run (Run ts rba lint) = runHelper rba lint ("run" : ts) Nothing 0
run c = runHelper False True rs Nothing 0
    where rs = g c
          g Install       = ["install"]
          g (Valgrind ts) = "valgrind" : ts
          g _             = undefined