From 0cdbcb247b409944f6367d0639416affba98b681 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 2 Nov 2014 19:27:40 +0100 Subject: [PATCH 1/7] Fix warning --- Language/Haskell/GhcMod/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index ccabaee..2773839 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -9,7 +9,7 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) import System.Directory (getTemporaryDirectory) -import System.FilePath (splitDrive, joinDrive, pathSeparators) +import System.FilePath (splitDrive, pathSeparators) import System.IO.Temp (createTempDirectory) #ifndef SPEC import Control.Applicative ((<$>)) From 94a60350c836a51c9bf573f014b66bf5ed4f46fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 2 Nov 2014 21:43:49 +0100 Subject: [PATCH 2/7] docs --- Language/Haskell/GhcMod/Error.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 7f7cdc7..9fa2b80 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -30,8 +30,9 @@ data GhcModError = GMENoMsg -- ^ Launching an operating system process failed. The first -- field is the command. | GMENoCabalFile + -- ^ No cabal file found. | GMETooManyCabalFiles [FilePath] - -- ^ No or too many cabal files found. + -- ^ Too many cabal files found. deriving (Eq,Show,Typeable) instance Exception GhcModError From 833d9ce058559aec3b1136ebe2fe64790ff77afa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Nov 2014 00:04:15 +0100 Subject: [PATCH 3/7] $HOME/.cabal is not a cabal file --- Language/Haskell/GhcMod/PathsAndFiles.hs | 13 +++++++++++-- test/PathsAndFilesSpec.hs | 5 +++++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 08bff0d..ccd0acf 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -30,7 +30,7 @@ type FileName = String -- or 'GMETooManyCabalFiles' findCabalFiles :: FilePath -> IO (Maybe FilePath) findCabalFiles directory = do - -- Look for cabal files in all parent directories of @dir@ + -- Look for cabal files in @dir@ and all it's parent directories dcs <- getCabalFiles `zipMapM` parents directory -- Extract first non-empty list, which represents a directory with cabal -- files. @@ -42,7 +42,16 @@ findCabalFiles directory = do -- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@. getCabalFiles :: DirPath -> IO [FileName] getCabalFiles dir = - filter ((==) ".cabal" . takeExtension) <$> getDirectoryContents dir + filterM isCabalFile =<< getDirectoryContents dir + where + isCabalFile f = do + exists <- doesFileExist f + return (exists && takeExtension' f == ".cabal") + + takeExtension' p = if takeFileName p == takeExtension p + then "" + else takeExtension p + makeAbsolute :: DirPath -> [FileName] -> [FilePath] makeAbsolute dir fs = (dir ) `map` fs diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index aa46f12..aa2a253 100644 --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -8,6 +8,7 @@ import Language.Haskell.GhcMod.GhcPkg #endif import System.Directory +import System.Environment import System.FilePath (()) import Test.Hspec @@ -28,3 +29,7 @@ spec = do it "returns Nothing if the sandbox config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing + + describe "getCabalFiles" $ do + it "doesn't think $HOME/.cabal is a cabal file" $ do + (getCabalFiles =<< getEnv "HOME") `shouldReturn` [] From 56cc237e26da5ec81b7c17e444082e8c318c2d19 Mon Sep 17 00:00:00 2001 From: Rob Everest Date: Sun, 2 Nov 2014 00:06:34 +1100 Subject: [PATCH 4/7] Support where clauses, let bindings and case expressions in case splitting (fixes #395) --- Language/Haskell/GhcMod/CaseSplit.hs | 17 +++++++++++++---- ghc-mod.cabal | 1 + test/CaseSplitSpec.hs | 21 +++++++++++++++++++++ test/data/case-split/Vect.hs | 15 +++++++++++++++ 4 files changed, 50 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 4d5a2ff..dabb67b 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -71,8 +71,8 @@ getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe getSrcSpanTypeForFnSplit modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) - match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI] + let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI case varPat of Nothing -> return Nothing Just varPat' -> do @@ -188,8 +188,11 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS , sVarSpan = sVS, sTycons = sT }) = let bindingText = getBindingText text sBS difference = srcSpanDifference sBS sVS - replaced = concatMap (replaceVarWithTyCon bindingText difference sVN) sT - in T.unpack $ T.intercalate (T.pack "\n") replaced + replaced = map (replaceVarWithTyCon bindingText difference sVN) sT + -- The newly generated bindings need to be indented to align with the + -- original binding. + replaced' = head replaced : map (indentBindingTo sBS) (tail replaced) + in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') getBindingText :: [T.Text] -> SrcSpan -> [T.Text] getBindingText text srcSpan = @@ -220,3 +223,9 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line else T.replicate spacesToAdd (T.pack " ") `T.append` line) [0 ..] text + +indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] +indentBindingTo bndLoc binds = + let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc + indent = (T.replicate (sl - 1) (T.pack " ") `T.append`) + in indent (head binds) : tail binds diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e167607..a6d87af 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -34,6 +34,7 @@ Extra-Source-Files: ChangeLog test/data/broken-cabal/cabal.sandbox.config.in test/data/broken-sandbox/*.cabal test/data/broken-sandbox/cabal.sandbox.config + test/data/case-split/*.hs test/data/cabal-flags/*.cabal test/data/check-test-subdir/*.cabal test/data/check-test-subdir/src/Check/Test/*.hs diff --git a/test/CaseSplitSpec.hs b/test/CaseSplitSpec.hs index 700cc68..5e5db3f 100644 --- a/test/CaseSplitSpec.hs +++ b/test/CaseSplitSpec.hs @@ -18,3 +18,24 @@ spec = do res `shouldBe` "24 1 24 30"++ " \"mlAppend Nil y = _mlAppend_body\NUL"++ "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n" + + it "works with case expressions" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 28 20 + res `shouldBe` "28 19 28 39"++ + " \"Nil -> _mlAppend_body\NUL"++ + " (Cons x'1 x'2) -> _mlAppend_body\"\n" + + it "works with where clauses" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 34 17 + res `shouldBe` "34 5 34 43"++ + " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" + + it "works with let bindings" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 38 33 + res `shouldBe` "38 21 38 59"++ + " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" diff --git a/test/data/case-split/Vect.hs b/test/data/case-split/Vect.hs index cd16e4c..9d11ada 100644 --- a/test/data/case-split/Vect.hs +++ b/test/data/case-split/Vect.hs @@ -22,3 +22,18 @@ data MyList a = Nil | Cons a (MyList a) mlAppend :: MyList a -> MyList a -> MyList a mlAppend x y = _mlAppend_body + +mlAppend2 :: MyList a -> MyList a -> MyList a +mlAppend2 x y = case x of + x' -> _mlAppend_body + +mlReverse :: MyList a -> MyList a +mlReverse xs = mlReverse' xs Nil + where + mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = _mlReverse_body + +mlReverse2 :: MyList a -> MyList a +mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = _mlReverse_body + in mlReverse' xs Nil From 506cf18885148251ada3e1fcfb0c96072e5c7c55 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Nov 2014 00:30:53 +0100 Subject: [PATCH 5/7] Don't use fromJust --- Language/Haskell/GhcMod/Monad.hs | 7 ++++--- test/CabalApiSpec.hs | 3 ++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 2e0cb4b..b2f1d96 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -99,7 +99,7 @@ import Control.Monad.Error (Error(..)) #endif import Control.Monad.Journal.Class -import Data.Maybe (fromJust, isJust) +import Data.Maybe (isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) import System.Directory (getCurrentDirectory) @@ -166,7 +166,7 @@ instance MonadIO m => MonadIO (GhcModT m) where where fromEx :: Exception e => SomeException -> e - fromEx = fromJust . fromException + fromEx se = let Just e = fromException se in e isIOError se = case fromException se of Just (_ :: IOError) -> True @@ -221,7 +221,8 @@ initializeFlagsWithCradle opt c cabal = isJust mCabalFile ghcopts = ghcUserOptions opt withCabal = do - pkgDesc <- parseCabalFile c $ fromJust mCabalFile + let Just cabalFile = mCabalFile + pkgDesc <- parseCabalFile c cabalFile compOpts <- getCompilerOptions ghcopts c pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 7f8e24f..a23c5f6 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -35,7 +35,8 @@ spec = do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do crdl <- findCradle - pkgDesc <- runD $ parseCabalFile crdl $ fromJust $ cradleCabalFile crdl + let cabalFile = cradleCabalFile crdl + pkgDesc <- runD $ parseCabalFile crdl cabalFile res <- runD $ getCompilerOptions [] crdl pkgDesc let res' = res { ghcOptions = ghcOptions res From 9a8a3651d0f52cf428f1627bc0f420906cb85679 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Nov 2014 00:45:27 +0100 Subject: [PATCH 6/7] Fix `findCabalFile` --- Language/Haskell/GhcMod/Cradle.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 15 +++++++-------- test/CabalApiSpec.hs | 3 +-- test/PathsAndFilesSpec.hs | 7 +++++++ 4 files changed, 16 insertions(+), 11 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index b5606b4..94ee836 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -32,7 +32,7 @@ cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl cabalCradle :: FilePath -> IO Cradle cabalCradle wdir = do - Just cabalFile <- findCabalFiles wdir + Just cabalFile <- findCabalFile wdir let cabalDir = takeDirectory cabalFile pkgDbStack <- getPackageDbStack cabalDir tmpDir <- newTempDir cabalDir diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index ccd0acf..064d39e 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -28,16 +28,19 @@ type FileName = String -- is assumed to be the project directory. If only one cabal file exists in this -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- or 'GMETooManyCabalFiles' -findCabalFiles :: FilePath -> IO (Maybe FilePath) -findCabalFiles directory = do +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile directory = do -- Look for cabal files in @dir@ and all it's parent directories dcs <- getCabalFiles `zipMapM` parents directory -- Extract first non-empty list, which represents a directory with cabal -- files. - case find (not . null) $ uncurry makeAbsolute `map` dcs of + case find (not . null) $ uncurry appendDir `map` dcs of Just [] -> throw $ GMENoCabalFile Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs a -> return $ head <$> a + where + appendDir :: DirPath -> [FileName] -> [FilePath] + appendDir dir fs = (dir ) `map` fs -- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@. getCabalFiles :: DirPath -> IO [FileName] @@ -45,17 +48,13 @@ getCabalFiles dir = filterM isCabalFile =<< getDirectoryContents dir where isCabalFile f = do - exists <- doesFileExist f + exists <- doesFileExist $ dir f return (exists && takeExtension' f == ".cabal") takeExtension' p = if takeFileName p == takeExtension p then "" else takeExtension p - -makeAbsolute :: DirPath -> [FileName] -> [FilePath] -makeAbsolute dir fs = (dir ) `map` fs - zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM (a,) $ f a) as diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index a23c5f6..67aa9f4 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -3,7 +3,6 @@ module CabalApiSpec where import Control.Applicative -import Data.Maybe import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types @@ -35,7 +34,7 @@ spec = do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do crdl <- findCradle - let cabalFile = cradleCabalFile crdl + let Just cabalFile = cradleCabalFile crdl pkgDesc <- runD $ parseCabalFile crdl cabalFile res <- runD $ getCompilerOptions [] crdl pkgDesc let res' = res { diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index aa2a253..c1b5143 100644 --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -33,3 +33,10 @@ spec = do describe "getCabalFiles" $ do it "doesn't think $HOME/.cabal is a cabal file" $ do (getCabalFiles =<< getEnv "HOME") `shouldReturn` [] + + describe "findCabalFile" $ do + it "works" $ do + findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal" + + it "finds cabal files in parent directories" $ do + findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal" From dbd94c47654d75cd88ae8d60c37cf29d1bee512b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Nov 2014 00:45:56 +0100 Subject: [PATCH 7/7] Revert ""expand" specifies "-b"." No idea what this was supposed to do, there's no mention of any -b option anywhere that I can find. This reverts commit f23b0db4df891b2481447c7828f184525f9aa435. --- elisp/ghc-info.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index d08d0dd..acfbb05 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -127,7 +127,7 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file "-b" "\n")) + (cmds (list "expand" file)) (source (ghc-run-ghc-mod cmds))) (when source (ghc-display