hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into release

Browse Source
This commit is contained in:
Daniel Gröber 2014-11-03 01:20:58 +01:00
commit ac4fadf0d0
11 changed files with 87 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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

2
Language/Haskell/GhcMod/Cradle.hs
View File

@ -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

3
Language/Haskell/GhcMod/Error.hs
View File

@ -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

7
Language/Haskell/GhcMod/Monad.hs
View File

@ -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

22
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -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

2
elisp/ghc-info.el
View File

@ -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

1
ghc-mod.cabal
View File

@ -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

4
test/CabalApiSpec.hs
View File

@ -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

21
test/CaseSplitSpec.hs
View File

@ -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"

12
test/PathsAndFilesSpec.hs
View File

@ -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"

15
test/data/case-split/Vect.hs
View File

@ -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