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/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/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 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/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 08bff0d..064d39e 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -28,24 +28,32 @@ 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 - -- Look for cabal files in all parent directories of @dir@ +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] getCabalFiles dir = - filter ((==) ".cabal" . takeExtension) <$> getDirectoryContents dir + filterM isCabalFile =<< getDirectoryContents dir + where + isCabalFile f = do + exists <- doesFileExist $ dir f + return (exists && takeExtension' f == ".cabal") -makeAbsolute :: DirPath -> [FileName] -> [FilePath] -makeAbsolute dir fs = (dir ) `map` fs + takeExtension' p = if takeFileName p == takeExtension p + then "" + else takeExtension p zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM (a,) $ f a) as 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1ca6050..5593d8f 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/CabalApiSpec.hs b/test/CabalApiSpec.hs index 7f8e24f..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,8 @@ spec = do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do crdl <- findCradle - pkgDesc <- runD $ parseCabalFile crdl $ fromJust $ cradleCabalFile crdl + let Just cabalFile = cradleCabalFile crdl + pkgDesc <- runD $ parseCabalFile crdl cabalFile res <- runD $ getCompilerOptions [] crdl pkgDesc let res' = res { ghcOptions = ghcOptions res 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/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index aa46f12..c1b5143 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,14 @@ 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` [] + + 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" 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