diff --git a/ats-pkg.cabal b/ats-pkg.cabal --- a/ats-pkg.cabal +++ b/ats-pkg.cabal @@ -1,5 +1,5 @@ name: ats-pkg -version: 2.4.2.19 +version: 2.5.0.3 synopsis: A build tool for ATS description: A collection of scripts to simplify building ATS projects. homepage: https://github.com/vmchale/atspkg#readme @@ -38,6 +38,7 @@ , Language.ATS.Package.Dependency , Language.ATS.Package.Compiler , Language.ATS.Package.Build + , Language.ATS.Package.Build.IO , Language.ATS.Package.Upgrade , Language.ATS.Package.Config , Language.ATS.Package.PackageSet @@ -64,14 +65,14 @@ , ansi-wl-pprint , shake-ats >= 1.3.0.0 , shake-ext >= 2.3.0.0 - , composition-prelude >= 1.1.0.2 + , composition-prelude >= 1.3.0.0 , optparse-applicative , zip-archive , temporary , ansi-wl-pprint , binary , dependency - , ats-setup + , ats-setup >= 0.3.1.1 build-tools: cpphs default-language: Haskell2010 if flag(development) diff --git a/man/atspkg.1 b/man/atspkg.1 --- a/man/atspkg.1 +++ b/man/atspkg.1 @@ -44,7 +44,7 @@ \f[B]check\f[] \- Check a pkg.dhall file to make sure it is well\-typed. .PP \f[B]list\f[] \- List all available packages in current package set. -.SS OPTIONS +.SH OPTIONS .TP .B \f[B]\-h\f[] \f[B]\-\-help\f[] Display help diff --git a/src/Language/ATS/Package.hs b/src/Language/ATS/Package.hs --- a/src/Language/ATS/Package.hs +++ b/src/Language/ATS/Package.hs @@ -6,12 +6,12 @@ , check , mkPkg , cleanAll - , upgradeAtsPkg , fetchDeps , mkBuildPlan , buildHelper , checkPkg , displayList + , upgradeBin -- * Types , Version (..) , Pkg (..) @@ -23,6 +23,7 @@ , ForeignCabal (..) , ATSPackageSet (..) , LibDep + , DepSelector , PackageError (..) -- * Lenses , dirLens diff --git a/src/Language/ATS/Package/Build.hs b/src/Language/ATS/Package/Build.hs --- a/src/Language/ATS/Package/Build.hs +++ b/src/Language/ATS/Package/Build.hs @@ -44,7 +44,7 @@ build :: [String] -- ^ Targets -> IO () build rs = bool (mkPkgEmpty [buildAll Nothing]) (mkPkgEmpty mempty) =<< check Nothing - where mkPkgEmpty ts = mkPkg False False True ts rs Nothing 1 + where mkPkgEmpty ts = mkPkg False True ts rs Nothing 1 -- TODO clean generated ATS mkClean :: Rules () @@ -131,39 +131,40 @@ toVerbosity 3 = Diagnostic toVerbosity _ = Diagnostic -- really should be a warning -options :: Bool -- ^ Whether to rebuild config - -> Bool -- ^ Whether to rebuild all targets +options :: Bool -- ^ Whether to rebuild all targets -> Bool -- ^ Whether to run the linter -> Int -- ^ Verbosity level -> [String] -- ^ A list of targets -> ShakeOptions -options rb rba lint v rs = shakeOptions { shakeFiles = ".atspkg" +options rba lint v rs = shakeOptions { shakeFiles = ".atspkg" , shakeThreads = 4 , shakeLint = bool Nothing (Just LintBasic) lint , shakeVersion = showVersion P.version - , shakeRebuild = foldMap g [ (rb, [(RebuildNow, ".atspkg/config")]) - , (rba, (RebuildNow ,) <$> rs) - ] + , shakeRebuild = rebuildTargets rba rs , shakeChange = ChangeModtimeAndDigestInput , shakeVerbosity = toVerbosity v } + +rebuildTargets :: Bool -- ^ Force rebuild of all targets + -> [a] -- ^ Targets + -> [(Rebuild, a)] +rebuildTargets rba rs = foldMap g [ (rba, (RebuildNow ,) <$> rs) ] where g (b, ts) = bool mempty ts b cleanConfig :: (MonadIO m) => [String] -> m Pkg cleanConfig ["clean"] = pure undefined cleanConfig _ = getConfig Nothing -mkPkg :: Bool -- ^ Whether to ignore cached package config - -> Bool -- ^ Rebuild all targets +mkPkg :: Bool -- ^ Force rebuild -> Bool -- ^ Run linter -> [IO ()] -- ^ Setup -> [String] -- ^ Targets -> Maybe String -- ^ Target triple -> Int -- ^ Verbosity -> IO () -mkPkg rb rba lint setup rs tgt v = do +mkPkg rba lint setup rs tgt v = do cfg <- cleanConfig rs - let opt = options rb rba lint v $ pkgToTargets cfg rs + let opt = options rba lint v $ pkgToTargets cfg rs shake opt $ mconcat [ want (pkgToTargets cfg rs) diff --git a/src/Language/ATS/Package/Build/IO.hs b/src/Language/ATS/Package/Build/IO.hs new file mode 100644 --- /dev/null +++ b/src/Language/ATS/Package/Build/IO.hs @@ -0,0 +1,56 @@ +module Language.ATS.Package.Build.IO ( clibSetup + , maybeExit + , pkgHome + , allSubdirs + ) where + +import Development.Shake.ATS +import Quaalude + +pkgHome :: CCompiler -> IO FilePath +pkgHome cc' = (++ ("/.atspkg/" ++ ccToDir cc')) <$> getEnv "HOME" + +allSubdirs :: FilePath -> IO [FilePath] +allSubdirs [] = pure mempty +allSubdirs d = do + d' <- listDirectory d + let d'' = ((d <> "/") <>) <$> d' + ds <- filterM doesDirectoryExist d'' + ds' <- mapM allSubdirs ds + pure $ join (ds : ds') + +maybeExit :: ExitCode -> IO () +maybeExit ExitSuccess = pure () +maybeExit x = exitWith x + +clibSetup :: CCompiler -- ^ C compiler + -> String -- ^ Library name + -> FilePath -- ^ Filepath to unpack to + -> IO () +clibSetup cc' lib' p = do + + -- Find configure script and make it executable + subdirs <- allSubdirs p + configurePath <- fromMaybe (p <> "/configure") <$> findFile subdirs "configure" + setFileMode configurePath ownerModes + + -- Set environment variables for configure script + h <- pkgHome cc' + let procEnv = Just [("CC", ccToString cc'), ("CFLAGS" :: String, "-I" <> h <> "include"), ("PATH", "/usr/bin:/bin")] + + biaxe [configure h configurePath procEnv, make, install] lib' p + +configure :: FilePath -> FilePath -> Maybe [(String, String)] -> String -> FilePath -> IO () +configure prefixPath configurePath procEnv lib' p = + putStrLn ("configuring " ++ lib' ++ "...") >> + silentCreateProcess ((proc configurePath ["--prefix", prefixPath, "--host", host]) { cwd = Just p, env = procEnv }) + +make :: String -> FilePath -> IO () +make lib' p = + putStrLn ("building " ++ lib' ++ "...") >> + silentCreateProcess ((proc "make" []) { cwd = Just p }) + +install :: String -> FilePath -> IO () +install lib' p = + putStrLn ("installing " ++ lib' ++ "...") >> + silentCreateProcess ((proc "make" ["install"]) { cwd = Just p }) diff --git a/src/Language/ATS/Package/Dependency.hs b/src/Language/ATS/Package/Dependency.hs --- a/src/Language/ATS/Package/Dependency.hs +++ b/src/Language/ATS/Package/Dependency.hs @@ -14,12 +14,12 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.Text.Lazy as TL import Development.Shake.ATS +import Language.ATS.Package.Build.IO import Language.ATS.Package.Config import Language.ATS.Package.Error import Language.ATS.Package.PackageSet import Language.ATS.Package.Type import Quaalude -import System.Process fetchDeps :: CCompiler -- ^ C compiler to use -> [IO ()] -- ^ Setup steps that can be performed concurrently @@ -30,35 +30,41 @@ -> Bool -- ^ Whether to perform setup anyhow. -> IO () fetchDeps cc' setup' deps cdeps atsBld cfgPath b' = - unless (null deps && null cdeps && b') $ do + + unless (null deps && null cdeps && null atsBld && b') $ do + putStrLn "Resolving dependencies..." + pkgSet <- unpack . defaultPkgs . decode <$> BSL.readFile cfgPath - deps' <- join <$> setBuildPlan "ats" pkgSet deps - atsDeps' <- join <$> setBuildPlan "ats-bld" pkgSet atsBld - putStrLn "Checking ATS dependencies..." + deps' <- setBuildPlan "ats" libDeps pkgSet deps + atsDeps' <- setBuildPlan "atsbld" libBldDeps pkgSet atsBld + cdeps' <- setBuildPlan "c" libDeps pkgSet cdeps + + -- Set up actions d <- (<> "lib/") <$> pkgHome cc' - let libs' = fmap (buildHelper False) deps' - cdeps' <- join <$> setBuildPlan "c" pkgSet cdeps - let unpacked = fmap (over dirLens (pack d <>)) cdeps' - clibs = fmap (buildHelper False) unpacked - atsLibs = fmap (buildHelper False) atsDeps' - atsBld' <- join <$> setBuildPlan "atsbld" pkgSet atsBld - parallel_ (extraWorkerWhileBlocked <$> (setup' ++ libs' ++ clibs ++ atsLibs)) - mapM_ (setup cc') unpacked - mapM_ atsPkgSetup atsBld' + let libs' = fmap (buildHelper False) (join deps') + unpacked = fmap (over dirLens (pack d <>)) <$> cdeps' + clibs = fmap (buildHelper False) (join unpacked) + atsLibs = fmap (buildHelper False) (join atsDeps') -pkgHome :: CCompiler -> IO FilePath -pkgHome cc' = (++ ("/.atspkg/" ++ ccToDir cc')) <$> getEnv "HOME" + -- Fetch all packages + parallel' $ join [ setup', libs', clibs, atsLibs ] -allSubdirs :: FilePath -> IO [FilePath] -allSubdirs [] = pure mempty -allSubdirs d = do - d' <- listDirectory d - let d'' = ((d <> "/") <>) <$> d' - ds <- filterM doesDirectoryExist d'' - ds' <- mapM allSubdirs ds - pure $ join (ds : ds') + -- Build C dependencies + unless (null unpacked) $ + mapM_ (setup cc') (join unpacked) + -- Build ATS Dependencies + unless (null atsDeps') $ + parallel_ (extraWorkerWhileBlocked <$> (mapM_ atsPkgSetup <$> atsDeps')) + +parallel' :: [IO ()] -> IO () +parallel' = parallel_ . fmap extraWorkerWhileBlocked + +waitCreateProcess :: CreateProcess -> IO () +waitCreateProcess = + maybeExit <=< waitForProcess <=< fmap (view _4) . createProcess + atslibSetup :: String -> FilePath -> IO () @@ -66,28 +72,11 @@ putStrLn $ "installing " ++ lib' ++ "..." subdirs <- allSubdirs p pkgPath <- fromMaybe p <$> findFile subdirs "atspkg.dhall" - void $ readCreateProcess ((proc "atspkg" ["install"]) { cwd = Just (takeDirectory pkgPath), std_err = CreatePipe }) "" - -clibSetup :: CCompiler -- ^ C compiler - -> String -- ^ Library name - -> FilePath -- ^ Filepath to unpack to - -> IO () -clibSetup cc' lib' p = do - subdirs <- allSubdirs p - configurePath <- fromMaybe (p <> "/configure") <$> findFile subdirs "configure" - setFileMode configurePath ownerModes - h <- pkgHome cc' - let procEnv = Just [("CC", ccToString cc'), ("CFLAGS" :: String, "-I" <> h <> "include"), ("PATH", "/usr/bin:/bin")] - putStrLn $ "configuring " ++ lib' ++ "..." - void $ readCreateProcess ((proc configurePath ["--prefix", h, "--host", host]) { cwd = Just p, env = procEnv, std_err = CreatePipe }) "" - putStrLn $ "building " ++ lib' ++ "..." - void $ readCreateProcess ((proc "make" []) { cwd = Just p, std_err = CreatePipe }) "" - putStrLn $ "installing " ++ lib' ++ "..." - void $ readCreateProcess ((proc "make" ["install"]) { cwd = Just p, std_err = CreatePipe }) "" + waitCreateProcess ((proc "atspkg" ["install"]) { cwd = Just (takeDirectory pkgPath), std_out = Inherit }) atsPkgSetup :: ATSDependency -> IO () -atsPkgSetup (ATSDependency lib' dirName' _ _ _ _) = do +atsPkgSetup (ATSDependency lib' dirName' _ _ _ _ _) = do lib'' <- (<> unpack lib') <$> pkgHome GCCStd b <- doesFileExist lib'' unless b $ do @@ -97,7 +86,7 @@ setup :: CCompiler -- ^ C compiler to use -> ATSDependency -- ^ ATSDependency itself -> IO () -setup cc' (ATSDependency lib' dirName' _ _ _ _) = do +setup cc' (ATSDependency lib' dirName' _ _ _ _ _) = do lib'' <- (<> unpack lib') <$> pkgHome cc' b <- doesFileExist lib'' unless b $ do @@ -124,20 +113,21 @@ extractFilesFromArchive [options] (toArchive response) buildHelper :: Bool -> ATSDependency -> IO () -buildHelper b (ATSDependency lib' dirName' url'' _ _ _) = do +buildHelper b (ATSDependency lib' dirName' url'' _ _ _ _) = do let (lib, dirName, url') = (lib', dirName', url'') & each %~ unpack + isLib = bool "" "library " b needsSetup <- not <$> doesDirectoryExist (dirName ++ if b then "/atspkg.dhall" else "") when needsSetup $ do - putStrLn ("Fetching library " ++ lib ++ "...") + putStrLn ("Fetching " ++ isLib ++ lib ++ "...") manager <- newManager tlsManagerSettings initialRequest <- parseRequest url' response <- responseBody <$> httpLbs (initialRequest { method = "GET" }) manager - putStrLn ("Unpacking library " ++ lib ++ "...") + putStrLn ("Unpacking " ++ isLib ++ lib ++ "...") if "zip" `TL.isSuffixOf` url'' then zipResponse dirName response else tarResponse url'' dirName response diff --git a/src/Language/ATS/Package/Exec.hs b/src/Language/ATS/Package/Exec.hs --- a/src/Language/ATS/Package/Exec.hs +++ b/src/Language/ATS/Package/Exec.hs @@ -30,14 +30,16 @@ data Command = Install | Build { _targets :: [String] - , _recache :: Bool , _archTarget :: Maybe String , _rebuildAll :: Bool , _verbosity :: Int , _lint :: Bool } | Clean - | Test { _targets :: [String], _lint :: Bool } + | Test { _targets :: [String] + , _rebuildAll :: Bool + , _lint :: Bool + } | Fetch { _url :: String } | Nuke | Upgrade @@ -79,7 +81,10 @@ run' = Run <$> targets "run" test' :: Parser Command -test' = Test <$> targets "test" <*> noLint +test' = Test + <$> targets "test" + <*> rebuild + <*> noLint valgrind :: Parser Command valgrind = Valgrind <$> targets "run with valgrind" @@ -94,24 +99,29 @@ <> 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" - <*> switch - (long "no-cache" - <> short 'c' - <> help "Turn off configuration caching") - <*> optional - (strOption - (long "target" - <> short 't' - <> help "Set target by using its triple")) - <*> switch - (long "rebuild" - <> short 'r' - <> help "Force rebuild of all targets") - <*> (length <$> - many (flag' () (short 'v' <> long "verbose" <> help "Turn up verbosity"))) + <*> triple + <*> rebuild + <*> verbosity <*> noLint noLint :: Parser Bool @@ -130,31 +140,31 @@ 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) + 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 False mempty ["install"] Nothing 0) + let a = withCurrentDirectory (takeDirectory pkgDir) (mkPkg False False mempty ["install"] Nothing 0) bool (buildAll (Just pkgDir) >> a) a =<< check (Just pkgDir) exec :: IO () exec = execParser wrapper >>= run -runHelper :: Bool -> Bool -> Bool -> [String] -> Maybe String -> Int -> IO () -runHelper rb rba lint rs tgt v = bool - (mkPkg rb rba lint [buildAll Nothing] rs tgt v) - (mkPkg rb rba lint mempty rs tgt v) - =<< check Nothing +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 = upgradeAtsPkg +run Upgrade = upgradeBin "vmchale" "atspkg" run Nuke = cleanAll run (Fetch u) = fetchPkg u -run Clean = mkPkg False False True mempty ["clean"] Nothing 0 -run (Build rs rb tgt rba v lint) = runHelper rb rba lint rs tgt v -run (Test ts lint) = runHelper False False lint ("test" : ts) Nothing 0 -run c = runHelper False False True rs Nothing 0 +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 c = runHelper False True rs Nothing 0 where rs = g c g Install = ["install"] g (Valgrind ts) = "valgrind" : ts diff --git a/src/Language/ATS/Package/PackageSet.hs b/src/Language/ATS/Package/PackageSet.hs --- a/src/Language/ATS/Package/PackageSet.hs +++ b/src/Language/ATS/Package/PackageSet.hs @@ -27,7 +27,7 @@ pretty v = text (show v) instance Pretty ATSDependency where - pretty (ATSDependency ln _ url md v _) = dullyellow (text (unpack ln)) <#> indent 4 (g md "url:" <+> text (unpack url) <#> "version:" <+> pretty v) <> hardline + pretty (ATSDependency ln _ url md v _ _) = dullyellow (text (unpack ln)) <#> indent 4 (g md "url:" <+> text (unpack url) <#> "version:" <+> pretty v) <> hardline where g (Just d) = ("description:" <+> text (unpack d) <#>) g Nothing = id @@ -35,33 +35,40 @@ pretty (ATSPackageSet ds) = mconcat (punctuate hardline (pretty <$> ds)) displayList :: String -> IO () -displayList = putDoc . pretty <=< listDeps +displayList = putDoc . pretty <=< listDeps True -listDeps :: String -> IO ATSPackageSet -listDeps = fmap s . input auto . pack - where s = over atsPkgSet (sortBy (compare `on` libName)) +listDeps :: Bool -- ^ Whether to sort dependencies + -> String -- ^ URL of package set + -> IO ATSPackageSet +listDeps b = fmap s . input auto . pack + where s = bool id s' b + s' = over atsPkgSet (sortBy (compare `on` libName)) setBuildPlan :: FilePath -- ^ Filepath for cache inside @.atspkg@ + -> DepSelector -> String -- ^ URL of package set to use. -> [String] -- ^ Libraries we want -> IO [[ATSDependency]] -setBuildPlan p url deps = do +setBuildPlan p getDeps url deps = do b <- doesFileExist depCache bool setBuildPlan' (decode <$> BSL.readFile depCache) b where depCache = ".atspkg/buildplan-" ++ p setBuildPlan' = do - pkgSet <- listDeps url - case mkBuildPlan pkgSet deps of + pkgSet <- listDeps False url + case mkBuildPlan getDeps pkgSet deps of Left x -> resolutionFailed x Right x -> createDirectoryIfMissing True ".atspkg" >> BSL.writeFile depCache (encode x) >> pure x -mkBuildPlan :: ATSPackageSet -> [String] -> DepM [[ATSDependency]] -mkBuildPlan aps@(ATSPackageSet ps) = finalize . resolve . fmap asDep <=< stringBuildPlan +mkBuildPlan :: DepSelector + -> ATSPackageSet + -> [String] + -> DepM [[ATSDependency]] +mkBuildPlan getDeps aps@(ATSPackageSet ps) = finalize . resolve . fmap (asDep getDeps) <=< stringBuildPlan where finalize = fmap (fmap (fmap (lookupVersions aps))) - resolve = resolveDependencies (atsPkgsToPkgs aps) + resolve = resolveDependencies (atsPkgsToPkgs libDeps aps) stringBuildPlan names = sequence [ lookup' x libs | x <- names ] where libs = (unpack . libName &&& id) <$> ps lookup' k vs = case lookup k vs of @@ -74,17 +81,21 @@ canonicalize (ATSConstraint Nothing Nothing) = None canonicalize (ATSConstraint (Just l) (Just u)) = Bounded (GreaterThanEq l) (LessThanEq u) -asDep :: ATSDependency -> Dependency -asDep ATSDependency{..} = Dependency (unpack libName) (g <$> libDeps) libVersion +asDep :: DepSelector + -> ATSDependency + -> Dependency +asDep getDeps d@ATSDependency{..} = Dependency (unpack libName) (g <$> getDeps d) libVersion where g = unpack *** canonicalize -atsPkgsToPkgs :: ATSPackageSet -> PackageSet Dependency -atsPkgsToPkgs (ATSPackageSet deps) = PackageSet $ foldr (.) id inserts mempty +atsPkgsToPkgs :: DepSelector + -> ATSPackageSet + -> PackageSet Dependency +atsPkgsToPkgs getDeps (ATSPackageSet deps) = PackageSet $ foldr (.) id inserts mempty where inserts = insert <$> deps insert dep = M.insertWith - (\_ -> S.insert (asDep dep)) + (\_ -> S.insert (asDep getDeps dep)) (unpack $ libName dep) - (S.singleton (asDep dep)) + (S.singleton (asDep getDeps dep)) lookupVersions :: ATSPackageSet -> Dependency -> ATSDependency lookupVersions (ATSPackageSet deps) (Dependency name _ v) = head (filter f deps) diff --git a/src/Language/ATS/Package/Type.hs b/src/Language/ATS/Package/Type.hs --- a/src/Language/ATS/Package/Type.hs +++ b/src/Language/ATS/Package/Type.hs @@ -21,6 +21,7 @@ , TargetPair (..) , CCompiler (..) , LibDep + , DepSelector -- * Lenses , dirLens ) where @@ -38,6 +39,9 @@ type LibDep = (Text, ATSConstraint) +-- | You likely want 'libDeps' or 'libBldDeps' +type DepSelector = ATSDependency -> [LibDep] + -- | Type for a dependency data ATSDependency = ATSDependency { libName :: Text -- ^ Library name, e.g. , dir :: Text -- ^ Directory we should unpack to @@ -45,6 +49,7 @@ , description :: Maybe Text -- ^ Package description , libVersion :: Version , libDeps :: [LibDep] -- ^ Strings containing dependencies + , libBldDeps :: [LibDep] -- ^ List of dependencies that must be built } deriving (Eq, Show, Generic, Interpret, Binary) diff --git a/src/Language/ATS/Package/Upgrade.hs b/src/Language/ATS/Package/Upgrade.hs --- a/src/Language/ATS/Package/Upgrade.hs +++ b/src/Language/ATS/Package/Upgrade.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.ATS.Package.Upgrade ( upgradeAtsPkg +module Language.ATS.Package.Upgrade ( upgradeBin ) where import qualified Data.ByteString.Lazy.Char8 as BSL @@ -8,7 +8,6 @@ import Quaalude import System.Info --- https://github.com/vmchale/atspkg/archive/master.zip manufacturer :: String manufacturer = case os of "darwin" -> "apple" @@ -23,18 +22,19 @@ home <- getEnv "HOME" pure $ home <> "/.local/bin/atspkg" --- TODO install `pi`? -upgradeAtsPkg :: IO () -upgradeAtsPkg = do +upgradeBin :: String -> String -> IO () +upgradeBin user proj = do + let inner = user <> "/" <> proj + putStrLn "Finding latest release..." manager <- newManager tlsManagerSettings - initialRequest <- parseRequest "https://github.com/vmchale/atspkg/releases/latest" + initialRequest <- parseRequest ("https://github.com/" ++ inner ++ "/releases/latest") response <- responseBody <$> httpLbs (initialRequest { method = "GET", redirectCount = 0 }) manager putStrLn "Downloading latest release..." let strVersion = BSL.takeWhile (/='"') . BSL.dropWhile (not . isDigit) . BSL.dropWhile (/='"') $ response - binRequest = "https://github.com/vmchale/atspkg/releases/download/" <> BSL.unpack strVersion <> "/atspkg-" <> targetArch + binRequest = "https://github.com/" <> inner <> "/releases/download/" <> BSL.unpack strVersion <> "/atspkg-" <> targetArch followupRequest <- parseRequest binRequest binBytes <- responseBody <$> httpLbs (followupRequest { method = "GET" }) manager diff --git a/src/Quaalude.hs b/src/Quaalude.hs --- a/src/Quaalude.hs +++ b/src/Quaalude.hs @@ -24,12 +24,19 @@ , first , second , getEnv + , exitWith + , ExitCode (ExitSuccess) , MonadIO (..) + -- * "System.Process.Ext" reëxports + , silentCreateProcess -- * "Data.Text.Lazy" reëxports , Text , pack , unpack + -- * "Control.Composition" reëxports + , biaxe , (.*) + , (.**) -- * Dhall reëxports , Interpret , Generic @@ -93,12 +100,12 @@ , view , _1 , _2 + , _4 , makeLensesFor , makeLenses , each , (&) , (%~) - -- , maybeDo ) where import Control.Arrow hiding ((<+>)) @@ -123,13 +130,12 @@ import Dhall hiding (bool) import System.Directory as X import System.Environment (getEnv) +import System.Exit (ExitCode (ExitSuccess), exitWith) +import System.Process as X +import System.Process.Ext import Text.PrettyPrint.ANSI.Leijen hiding (bool, (<>)) infixr 5 <#> - --- maybeDo :: Monad m => Maybe (m ()) -> m () --- maybeDo (Just a) = a --- maybeDo _ = pure () -- | Same as "Text.PrettyPrint.ANSI.Leijen"'s @<$>@, but doesn't clash with the -- prelude. diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -8,10 +8,10 @@ extra-deps: - dhall-1.9.1 - shake-ext-2.5.0.0 - - composition-prelude-1.2.0.1 - - language-ats-0.3.0.4 + - composition-prelude-1.3.0.3 + - language-ats-1.0.1.0 - cli-setup-0.2.0.1 - - ats-setup-0.3.0.2 + - ats-setup-0.3.1.1 - hspec-dirstream-0.3.0.0 - dirstream-1.0.3 flags: