diff --git a/CHANGELOG.md b/CHANGELOG.md index 5c55d57..4b79564 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # What's new? +## New in 1.1.2 + +[Stack](http://www.haskellstack.org) compatibility. + ## New in 1.1.1 GHC 7.10 compatibility. diff --git a/haskell-awk.cabal b/haskell-awk.cabal index 17acda7..ab503c1 100644 --- a/haskell-awk.cabal +++ b/haskell-awk.cabal @@ -52,14 +52,16 @@ Executable hawk , directory , easy-file , exceptions >=0.1 + , extra , filepath , haskell-awk , haskell-src-exts >=1.16.0 , hint >=0.3.3.5 , mtl >=2.1.2 , network >=2.3.1.0 - , stringsearch >=0.3.6.4 , process + , stringsearch >=0.3.6.4 + , template-haskell , time , transformers >=0.3.0.0 hs-source-dirs: src @@ -87,21 +89,23 @@ Test-suite reference , containers , directory , doctest >=0.3.0 + , easy-file , exceptions >=0.1 - , test-framework >=0.1 - , test-framework-hunit >=0.2.0 - , temporary >=1.0 + , extra + , filepath , haskell-awk - , hspec >=0.2.0 - , HUnit >=1.1 - , easy-file , haskell-src-exts >=1.14.0 , hint >=0.3.3.5 - , filepath + , hspec >=0.2.0 + , HUnit >=1.1 , mtl >=2.1.2 , network >=2.3.1.0 , process , stringsearch >=0.3.6.4 + , template-haskell + , temporary >=1.0 + , test-framework >=0.1 + , test-framework-hunit >=0.2.0 , time , transformers >=0.3.0.0 Default-Language: Haskell98 diff --git a/src/System/Console/Hawk/Sandbox.hs b/src/System/Console/Hawk/Sandbox.hs index ad69e31..7e47356 100644 --- a/src/System/Console/Hawk/Sandbox.hs +++ b/src/System/Console/Hawk/Sandbox.hs @@ -19,17 +19,22 @@ -- installed libraries. If hawk has been installed with a sandbox, its -- binary and its library will be installed in a local folder instead of -- in the global location. +{-# LANGUAGE TemplateHaskell, TupleSections #-} module System.Console.Hawk.Sandbox ( extraGhcArgs , runHawkInterpreter ) where import Control.Applicative -import Data.List +import Control.Monad +import Data.List.Extra (wordsBy) +import Data.Maybe import Language.Haskell.Interpreter (InterpreterT, InterpreterError) import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs) -import System.Directory (getDirectoryContents) -import System.FilePath (pathSeparator) +import Language.Haskell.TH.Syntax (lift, runIO) +import System.Directory.PathFinder +import System.Environment (getEnvironment) +import System.FilePath (()) import Text.Printf (printf) -- magic self-referential module created by cabal @@ -37,78 +42,80 @@ import Paths_haskell_awk (getBinDir) data Sandbox = Sandbox - { folder :: FilePath - , packageFilePrefix :: String - , packageFileSuffix :: String - } deriving Show - -cabalDev, cabalSandbox :: Sandbox -cabalDev = Sandbox "cabal-dev" "packages-" ".conf" -cabalSandbox = Sandbox ".cabal-sandbox" "" "-packages.conf.d" - --- all the sandbox systems we support. + { sandboxPathFinder :: PathFinder + , packageDbFinder :: MultiPathFinder + } + +dotCabal :: Sandbox +dotCabal = Sandbox (basenameIs ".cabal") $ do + relativePath (".." ".ghc") + someChild + relativePath "package.conf.d" + +cabalSandbox :: Sandbox +cabalSandbox = Sandbox (basenameIs ".cabal-sandbox") $ do + someChild + basenameMatches "" "-packages.conf.d" + +-- All the sandbox systems we support. +-- We also support stack and cabal-dev, via HASKELL_PACKAGE_SANDBOXES. sandboxes :: [Sandbox] -sandboxes = [cabalDev, cabalSandbox] - - --- a version of isSuffixOf which returns the string stripped of its suffix. -isSuffixOf' :: String -> String -> Maybe String -isSuffixOf' suffix s = if suffix `isSuffixOf` s - then Just (take (n - m) s) - else Nothing - where - n = length s - m = length suffix - - --- convert slashes to backslashes if needed -path :: String -> String -path = map replaceSeparator where - replaceSeparator '/' = pathSeparator - replaceSeparator x = x - - --- if hawk has been compiled by a sandboxing tool, --- its binary has been placed in a special folder. --- --- return something like (Just "/.../cabal-dev") -getSandboxDir :: Sandbox -> IO (Maybe String) -getSandboxDir sandbox = do - dir <- Paths_haskell_awk.getBinDir - let sandboxFolder = folder sandbox - let suffix = path (sandboxFolder ++ "/bin") - let basePath = suffix `isSuffixOf'` dir - let sandboxPath = fmap (++ sandboxFolder) basePath - return sandboxPath - --- something like "packages-7.6.3.conf" -isPackageFile :: Sandbox -> FilePath -> Bool -isPackageFile sandbox f = packageFilePrefix sandbox `isPrefixOf` f - && packageFileSuffix sandbox `isSuffixOf` f +sandboxes = [dotCabal, cabalSandbox] + + +-- something like (Just "/.../.cabal-sandbox") +findSandboxPath :: Sandbox -> IO (Maybe FilePath) +findSandboxPath sandbox = do + bindir <- Paths_haskell_awk.getBinDir + let sandboxPathFromBin = relativePath ".." >> sandboxPathFinder sandbox + runPathFinder sandboxPathFromBin bindir + +-- something like (cabalSandbox, "/.../.cabal-sandbox") +detectCabalSandbox :: IO (Sandbox, FilePath) +detectCabalSandbox = do + detectedSandboxes <- forM sandboxes $ \sandbox -> do + sandboxPath <- findSandboxPath sandbox + return $ (sandbox,) <$> sandboxPath + case catMaybes detectedSandboxes of + [r] -> return r + [] -> error "No package-db found. Did you install Hawk in an unusual way?" + rs -> let paths = fmap snd rs + msg = printf "Multiple sandboxes found: %s\nDon't know which one to use, aborting." + (show paths) + in error msg -- something like "/.../cabal-dev/package-7.6.3.conf" -getPackageFile :: Sandbox -> String -> IO String -getPackageFile sandbox dir = do - files <- getDirectoryContents dir - case filter (isPackageFile sandbox) files of - [file] -> return $ printf (path "%s/%s") dir file - [] -> fail' "no package-db" - _ -> fail' $ "multiple package-db's" - where - fail' s = error $ printf "%s found in sandbox %s" s (folder sandbox) - -sandboxSpecificGhcArgs :: Sandbox -> IO [String] -sandboxSpecificGhcArgs sandbox = do - sandboxDir <- getSandboxDir sandbox - case sandboxDir of - Nothing -> return [] - Just dir -> do packageFile <- getPackageFile sandbox dir - let arg = printf "-package-db %s" packageFile - return [arg] - - +detectCabalPackageDb :: IO String +detectCabalPackageDb = do + (sandbox, sandboxPath) <- detectCabalSandbox + let fail' s = error $ printf "%s found in sandbox %s" s sandboxPath + packageDbPaths <- runMultiPathFinder (packageDbFinder sandbox) sandboxPath + case packageDbPaths of + [packageDb] -> return packageDb + [] -> fail' "no package-db" + _ -> fail' "multiple package-db's" + +-- stack requires two package-databases, the second is passed at compile time +-- via an environment variable. +detectEnvPackageDbs :: Maybe [String] +detectEnvPackageDbs = $(do + env <- runIO getEnvironment + lift $ wordsBy (== ':') <$> lookup "HASKELL_PACKAGE_SANDBOXES" env + ) + +-- prefer the env-provided list of package-dbs if there is one, otherwise +-- try to pick a package-db path based on the installation path given by cabal. +detectPackageDbs :: IO [String] +detectPackageDbs = case detectEnvPackageDbs of + Just packageDbs -> return packageDbs + Nothing -> do + packageDb <- detectCabalPackageDb + return [packageDb] + + +-- something like ["-package-db /.../cabal-dev/package-7.6.3.conf"] extraGhcArgs :: IO [String] -extraGhcArgs = concat <$> mapM sandboxSpecificGhcArgs sandboxes +extraGhcArgs = fmap (printf "-package-db %s") <$> detectPackageDbs -- | a version of runInterpreter which can load libraries -- installed along hawk's sandbox folder, if applicable. diff --git a/src/System/Directory/PathFinder.hs b/src/System/Directory/PathFinder.hs new file mode 100644 index 0000000..51c8719 --- /dev/null +++ b/src/System/Directory/PathFinder.hs @@ -0,0 +1,56 @@ +-- | Tiny DSL for finding a path from the current path. +{-# LANGUAGE LambdaCase #-} +module System.Directory.PathFinder where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State +import Data.List +import System.Directory +import System.FilePath + +import System.Directory.Extra + + +type PathFinder = StateT FilePath (MaybeT IO) () +type MultiPathFinder = StateT FilePath (ListT IO) () + +runPathFinder :: PathFinder -> FilePath -> IO (Maybe FilePath) +runPathFinder p pwd = runMaybeT (execStateT p pwd) + +runMultiPathFinder :: MultiPathFinder -> FilePath -> IO [FilePath] +runMultiPathFinder p pwd = runListT (execStateT p pwd) + + +basenameIs :: MonadPlus m => String -> StateT FilePath m () +basenameIs s = do + pwd <- get + guard (takeFileName pwd == s) + +basenameMatches :: MonadPlus m => String -> String -> StateT FilePath m () +basenameMatches prefix suffix = do + pwd <- get + guard (prefix `isPrefixOf` pwd && suffix `isSuffixOf` pwd) + +hasAncestor :: MonadPlus m => String -> StateT FilePath m () +hasAncestor s = do + pwd <- get + guard (s `elem` splitDirectories pwd) + +relativePath :: (MonadIO m, MonadPlus m) => FilePath -> StateT FilePath m () +relativePath rel = do + pwd <- get + let pwd' = pwd rel + exists <- liftIO $ doesDirectoryExist pwd' + guard exists + pwd'' <- liftIO $ canonicalizePath pwd' + put pwd'' + +someChild :: MultiPathFinder +someChild = do + pwd <- get + child <- lift $ ListT $ getDirectoryContents pwd + put (pwd child)