From c0ae9d96b0b5fabf78927f10d8e2e505655348cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 00:29:30 -0400 Subject: [PATCH 1/7] DSL for finding paths --- src/System/Directory/PathFinder.hs | 55 ++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 src/System/Directory/PathFinder.hs diff --git a/src/System/Directory/PathFinder.hs b/src/System/Directory/PathFinder.hs new file mode 100644 index 0000000..4b22a05 --- /dev/null +++ b/src/System/Directory/PathFinder.hs @@ -0,0 +1,55 @@ +-- | 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 + put pwd' + +someChild :: MultiPathFinder +someChild = do + pwd <- get + child <- lift $ ListT $ getDirectoryContents pwd + put (pwd child) From 087df5df17c32eb5b2a721c714450ddc66b7317d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 00:51:39 -0400 Subject: [PATCH 2/7] rewrite sandbox detection Now using the PathFinder DSL. Installing to ~/.cabal now counts as some kind of "sandbox". Installing via stack is also considered a kind of sandbox. --- src/System/Console/Hawk/Sandbox.hs | 135 ++++++++++++++--------------- src/System/Directory/PathFinder.hs | 3 +- 2 files changed, 68 insertions(+), 70 deletions(-) diff --git a/src/System/Console/Hawk/Sandbox.hs b/src/System/Console/Hawk/Sandbox.hs index ad69e31..f9f2505 100644 --- a/src/System/Console/Hawk/Sandbox.hs +++ b/src/System/Console/Hawk/Sandbox.hs @@ -19,17 +19,19 @@ -- 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 TupleSections #-} module System.Console.Hawk.Sandbox ( extraGhcArgs , runHawkInterpreter ) where import Control.Applicative -import Data.List +import Control.Monad +import Data.Maybe import Language.Haskell.Interpreter (InterpreterT, InterpreterError) import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs) -import System.Directory (getDirectoryContents) -import System.FilePath (pathSeparator) +import System.Directory.PathFinder +import System.FilePath (()) import Text.Printf (printf) -- magic self-referential module created by cabal @@ -37,78 +39,73 @@ 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" + { sandboxPathFinder :: PathFinder + , packageDbFinder :: MultiPathFinder + } + +cabalDev :: Sandbox +cabalDev = Sandbox (basenameIs "cabal-dev") $ do + someChild + basenameMatches "packages-" ".conf" + +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" + +stackTool :: Sandbox +stackTool = Sandbox (hasAncestor ".stack-work") $ do + relativePath "pkgdb" -- all the sandbox systems we support. 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 = [cabalDev, dotCabal, cabalSandbox, stackTool] + + +-- 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") +detectSandbox :: IO (Sandbox, FilePath) +detectSandbox = 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] - - +detectPackageDb :: IO String +detectPackageDb = do + (sandbox, sandboxPath) <- detectSandbox + 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" + + +-- something like ["-package-db /.../cabal-dev/package-7.6.3.conf"] extraGhcArgs :: IO [String] -extraGhcArgs = concat <$> mapM sandboxSpecificGhcArgs sandboxes +extraGhcArgs = do + packageDb <- detectPackageDb + return [printf "-package-db %s" packageDb] -- | 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 index 4b22a05..51c8719 100644 --- a/src/System/Directory/PathFinder.hs +++ b/src/System/Directory/PathFinder.hs @@ -46,7 +46,8 @@ relativePath rel = do let pwd' = pwd rel exists <- liftIO $ doesDirectoryExist pwd' guard exists - put pwd' + pwd'' <- liftIO $ canonicalizePath pwd' + put pwd'' someChild :: MultiPathFinder someChild = do From b7ae45a64c1bc2b91682ae885c127b4af7293566 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 12:11:05 -0400 Subject: [PATCH 3/7] use HASKELL_PACKAGE_SANDBOX if available --- haskell-awk.cabal | 2 ++ src/System/Console/Hawk/Sandbox.hs | 36 ++++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/haskell-awk.cabal b/haskell-awk.cabal index 17acda7..8b35612 100644 --- a/haskell-awk.cabal +++ b/haskell-awk.cabal @@ -52,6 +52,7 @@ Executable hawk , directory , easy-file , exceptions >=0.1 + , extra , filepath , haskell-awk , haskell-src-exts >=1.16.0 @@ -60,6 +61,7 @@ Executable hawk , network >=2.3.1.0 , stringsearch >=0.3.6.4 , process + , template-haskell , time , transformers >=0.3.0.0 hs-source-dirs: src diff --git a/src/System/Console/Hawk/Sandbox.hs b/src/System/Console/Hawk/Sandbox.hs index f9f2505..5c587cb 100644 --- a/src/System/Console/Hawk/Sandbox.hs +++ b/src/System/Console/Hawk/Sandbox.hs @@ -19,7 +19,7 @@ -- 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 TupleSections #-} +{-# LANGUAGE TemplateHaskell, TupleSections #-} module System.Console.Hawk.Sandbox ( extraGhcArgs , runHawkInterpreter @@ -27,10 +27,13 @@ module System.Console.Hawk.Sandbox import Control.Applicative import Control.Monad +import Data.List.Extra (wordsBy) import Data.Maybe import Language.Haskell.Interpreter (InterpreterT, InterpreterError) import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs) +import Language.Haskell.TH.Syntax (lift, runIO) import System.Directory.PathFinder +import System.Environment (getEnvironment) import System.FilePath (()) import Text.Printf (printf) @@ -76,8 +79,8 @@ findSandboxPath sandbox = do runPathFinder sandboxPathFromBin bindir -- something like (cabalSandbox, "/.../.cabal-sandbox") -detectSandbox :: IO (Sandbox, FilePath) -detectSandbox = do +detectCabalSandbox :: IO (Sandbox, FilePath) +detectCabalSandbox = do detectedSandboxes <- forM sandboxes $ \sandbox -> do sandboxPath <- findSandboxPath sandbox return $ (sandbox,) <$> sandboxPath @@ -90,9 +93,9 @@ detectSandbox = do in error msg -- something like "/.../cabal-dev/package-7.6.3.conf" -detectPackageDb :: IO String -detectPackageDb = do - (sandbox, sandboxPath) <- detectSandbox +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 @@ -100,12 +103,27 @@ detectPackageDb = do [] -> 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 = do - packageDb <- detectPackageDb - return [printf "-package-db %s" packageDb] +extraGhcArgs = fmap (printf "-package-db %s") <$> detectPackageDbs -- | a version of runInterpreter which can load libraries -- installed along hawk's sandbox folder, if applicable. From 54428e7bfbf672e4a125c203c2a0e22480bee8ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 12:13:11 -0400 Subject: [PATCH 4/7] cabal-dev and stack no longer need detection their sandboxes are now detected via HASKELL_PACKAGE_SANDBOXES, no need for custom detection logic. --- src/System/Console/Hawk/Sandbox.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/System/Console/Hawk/Sandbox.hs b/src/System/Console/Hawk/Sandbox.hs index 5c587cb..7e47356 100644 --- a/src/System/Console/Hawk/Sandbox.hs +++ b/src/System/Console/Hawk/Sandbox.hs @@ -46,11 +46,6 @@ data Sandbox = Sandbox , packageDbFinder :: MultiPathFinder } -cabalDev :: Sandbox -cabalDev = Sandbox (basenameIs "cabal-dev") $ do - someChild - basenameMatches "packages-" ".conf" - dotCabal :: Sandbox dotCabal = Sandbox (basenameIs ".cabal") $ do relativePath (".." ".ghc") @@ -62,13 +57,10 @@ cabalSandbox = Sandbox (basenameIs ".cabal-sandbox") $ do someChild basenameMatches "" "-packages.conf.d" -stackTool :: Sandbox -stackTool = Sandbox (hasAncestor ".stack-work") $ do - relativePath "pkgdb" - --- all the sandbox systems we support. +-- All the sandbox systems we support. +-- We also support stack and cabal-dev, via HASKELL_PACKAGE_SANDBOXES. sandboxes :: [Sandbox] -sandboxes = [cabalDev, dotCabal, cabalSandbox, stackTool] +sandboxes = [dotCabal, cabalSandbox] -- something like (Just "/.../.cabal-sandbox") From de66d053b654206971c9250faf796fc1829fd0e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 12:38:51 -0400 Subject: [PATCH 5/7] fix dependencies of the test suite --- haskell-awk.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haskell-awk.cabal b/haskell-awk.cabal index 8b35612..5739174 100644 --- a/haskell-awk.cabal +++ b/haskell-awk.cabal @@ -90,6 +90,8 @@ Test-suite reference , directory , doctest >=0.3.0 , exceptions >=0.1 + , extra + , template-haskell , test-framework >=0.1 , test-framework-hunit >=0.2.0 , temporary >=1.0 From 4f44cf888e98e341f483f76db304c8de929128f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20Ge=CC=81lineau?= Date: Sun, 19 Jul 2015 12:41:42 -0400 Subject: [PATCH 6/7] sort dependencies --- haskell-awk.cabal | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/haskell-awk.cabal b/haskell-awk.cabal index 5739174..ab503c1 100644 --- a/haskell-awk.cabal +++ b/haskell-awk.cabal @@ -59,8 +59,8 @@ Executable hawk , 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 @@ -89,23 +89,23 @@ Test-suite reference , containers , directory , doctest >=0.3.0 + , easy-file , exceptions >=0.1 , extra - , template-haskell - , test-framework >=0.1 - , test-framework-hunit >=0.2.0 - , temporary >=1.0 + , 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 From dafa850813e4deb6988972e9146198ac0edc483a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 19 May 2016 21:47:17 -0400 Subject: [PATCH 7/7] list 1.1.2 changes --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) 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.