diff --git a/Hub/CommandLine.hs b/Hub/CommandLine.hs --- a/Hub/CommandLine.hs +++ b/Hub/CommandLine.hs @@ -52,7 +52,7 @@ | UnlockCL Hub | PathCL Hub | XmlCL Hub - | InitCL Hub HubName Bool -- -s + | InitCL Hub HubName Bool Bool -- -s -x (-x => -s) | CommentCL Hub String | CpCL Hub HubName | MvCL Hub HubName @@ -69,7 +69,10 @@ deriving (Show) +data InitType = SetIT | NoSetIT | SandboxIT + deriving (Show) + prog, hub_dispatch :: [String] -> IO (Maybe CommandLine) prog as = @@ -113,13 +116,15 @@ ["path" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ PathCL hub ["xml" ] -> discover Nothing >>= \ hub -> return $ Just $ XmlCL hub ["xml" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ XmlCL hub - ["init" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True - ["init","-n" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True - ["init","-n" ,hn ] -> hub_uniq (Just hn) >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True - ["init","-s" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' True - ["init","-s" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' True - ["init" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' False - ["init" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' False + ["init" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True False + ["init","-n" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True False + ["init","-n" ,hn ] -> hub_uniq (Just hn) >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True False + ["init","-s" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' True False + ["init","-s" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' True False + ["init","-x" ,hn ] -> hub_uniq (Just hn) >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True True + ["init","-x" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' True True + ["init" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' False False + ["init" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' False False ["comment" ,cmt ] -> discover Nothing >>= \ hub -> return $ Just $ CommentCL hub cmt ["comment" ,hn,cmt ] -> discover (Just hn) >>= \ hub -> return $ Just $ CommentCL hub cmt ["cp" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ CpCL hub hn' diff --git a/Hub/Commands.hs b/Hub/Commands.hs --- a/Hub/Commands.hs +++ b/Hub/Commands.hs @@ -175,9 +175,9 @@ _xml :: Hub -> IO () _xml hub = readAFile (path__HUB hub) >>= putStr -_init :: Hub -> HubName -> Bool -> IO () -_init hub0 hn sf = - do hub <- createHub' False hub0 hn sf +_init :: Hub -> HubName -> Bool -> Bool -> IO () +_init hub0 hn sf xf = + do hub <- createHub' False hub0 hn sf xf when sf $ _set hub _comment :: Hub -> String -> IO () diff --git a/Hub/Directory.hs b/Hub/Directory.hs --- a/Hub/Directory.hs +++ b/Hub/Directory.hs @@ -33,6 +33,7 @@ ) where +import Control.Applicative import qualified Control.Exception as E import Control.Monad import Data.List @@ -185,19 +186,22 @@ prs' _ = Nothing createHub :: Bool -> Hub -> HubName -> IO () -createHub cp hub0 hn = const () `fmap` createHub' cp hub0 hn False +createHub cp hub0 hn = const () `fmap` createHub' cp hub0 hn False False -createHub' :: Bool -> Hub -> HubName -> Bool -> IO Hub -createHub' cp hub0 hn sf = +createHub' :: Bool -> Hub -> HubName -> Bool -> Bool -> IO Hub +createHub' cp hub0 hn sf xf = do userHubAvailable hn - (h_fp,lib,db) <- user_hub_paths hn + (h_fp,lib,db0) <- user_hub_paths hn + db <- case xf of + True -> sandbox hub0 + False -> return db0 createDirectoryIfMissing True lib case cp of True -> - do db0 <- hub_user_db hub0 - cpFileDir db0 db + do db_ <- hub_user_db hub0 + cpFileDir db_ db False -> - pkg_init hub0 db + when (not xf) $ pkg_init hub0 db dy <- defaultDirectoryPath let gh = maybe (name__HUB hub0) id $ usr_ghHUB hub0 lk = lockedHUB hub0 @@ -474,6 +478,21 @@ home :: IO FilePath home = catchIO (getEnv "HOME") $ \_ -> return "/" + + + +-- +-- Creating a Cabal Sandbox +-- + +sandbox :: Hub -> IO FilePath +sandbox hub = do + execP HubO (EE InheritRS InheritRS [] []) FullMDE hub CabalP ["sandbox","init"] + cwd <- getCurrentDirectory + dirs <- filter ("ghc" `isInfixOf`) <$> getDirectoryContents ".cabal-sandbox" + case dirs of + [dir] -> return $ cwd ".cabal-sandbox" dir + _ -> error "no package database located in the sandbox" diff --git a/Hub/Directory/Allocate.hs b/Hub/Directory/Allocate.hs new file mode 100644 --- /dev/null +++ b/Hub/Directory/Allocate.hs @@ -0,0 +1,37 @@ +-- +-- >>> Hub.Directory.Allocate <<< +-- +-- This module logically belongs to HUb.Directory and would be placed there +-- except doing so would establish an import sysle between Hub.Hub and +-- Hub.Directory through Hub.Parse. +-- +-- (c) 2011-2012 Chris Dornan + + +module Hub.Directory.Allocate + ( allocate + ) where + +import qualified Control.Exception as E +import Text.Printf +import System.Directory +import System.Environment +import Hub.System + + +-- allocate a library directory from the heap in the (default) directory + +allocate :: IO FilePath +allocate = + do hme <- home + createDirectoryIfMissing True $ printf "%s/.hubrc/heap" hme + i <- inc $ printf "%s/.hubrc/heap/counter.txt" hme + let pth = printf "%s/.hubrc/heap/%d" hme i + createDirectoryIfMissing True pth + return pth + +home :: IO FilePath +home = catchIO (getEnv "HOME") $ \_ -> return "/" + +catchIO :: IO a -> (IOError->IO a) -> IO a +catchIO = E.catch diff --git a/Hub/SaveLoad.hs b/Hub/SaveLoad.hs --- a/Hub/SaveLoad.hs +++ b/Hub/SaveLoad.hs @@ -64,7 +64,7 @@ _ -> oops HubO mm_msg g_hub <- discover $ Just gh hub <- case mb_hub of - Nothing -> createHub' False g_hub hn False + Nothing -> createHub' False g_hub hn False False Just hub -> return hub nks0 <- (map iden2nick . Map.keys) `fmap` packageDB hub return $ PD hub (nks0\\nks) (nks\\nks0) nks diff --git a/Version.hs b/Version.hs new file mode 100644 --- /dev/null +++ b/Version.hs @@ -0,0 +1,20 @@ +-- +-- >>> Version <<< +-- +-- Keeper of the version information. +-- +-- (c) 2011-2015 Chris Dornan + + +module Version + ( version + , main + ) where + + +version :: String +version = "1.9.0.1" + + +main :: IO () +main = putStrLn version diff --git a/hub.cabal b/hub.cabal --- a/hub.cabal +++ b/hub.cabal @@ -1,5 +1,5 @@ Name: hub -Version: 1.4.0 +Version: 1.9.0.1 Copyright: Chris Dornan, 2011-2015 Maintainer: Chris Dornan Author: Chris Dornan @@ -82,6 +82,7 @@ Hub.Commands Hub.SaveLoad Hub.Directory + Hub.Directory.Allocate Hub.Discover Hub.FilePaths Hub.Help @@ -93,5 +94,6 @@ Hub.Prog Hub.System Hub.Poss + Version GHC-options: -Wall Default-language: Haskell2010 diff --git a/hub.hs b/hub.hs --- a/hub.hs +++ b/hub.hs @@ -44,7 +44,7 @@ UnlockCL hub -> _unlock hub PathCL hub -> _path hub XmlCL hub -> _xml hub - InitCL hub hn set -> _init hub hn set + InitCL hub hn sf xf -> _init hub hn sf xf CommentCL hub cmt -> _comment hub cmt CpCL hub hn -> _cp hub hn MvCL hub hn -> _mv hub hn