Bring test suite up to date

test/CabalHelperSpec.hs

@@ -0,0 +1,70 @@
+module CabalHelperSpec where
+
+import Control.Arrow
+import Control.Applicative
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Error
+import Test.Hspec
+import System.Directory
+import System.FilePath
+import System.Process (readProcess)
+
+import Dir
+import TestUtils
+import Data.List
+
+import Config (cProjectVersionInt)
+
+ghcVersion :: Int
+ghcVersion = read cProjectVersionInt
+
+gmeProcessException :: GhcModError -> Bool
+gmeProcessException GMEProcess {} = True
+gmeProcessException _ = False
+
+pkgOptions :: [String] -> [String]
+pkgOptions [] = []
+pkgOptions (_:[]) = []
+pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs
+                    | otherwise = pkgOptions (y:xs)
+ where
+   stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)
+   name s = reverse $ stripDash $ stripDash $ reverse s
+
+idirOpts :: [(c, [String])] -> [(c, [String])]
+idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))
+
+spec :: Spec
+spec = do
+    describe "getGhcOptions" $ do
+        it "throws an exception if the cabal file is broken" $ do
+            let tdir = "test/data/broken-caba"
+            runD' tdir getGhcOptions `shouldThrow` anyIOException
+
+        it "handles sandboxes correctly" $ do
+            let tdir = "test/data/cabal-project"
+            cwd <- getCurrentDirectory
+
+            opts <- runD' tdir getGhcOptions
+
+            if ghcVersion < 706
+              then forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
+              else forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
+
+        it "extracts build dependencies" $ do
+            let tdir = "test/data/cabal-project"
+            opts <- runD' tdir getGhcOptions
+            let ghcOpts = snd $ head opts
+                pkgs = pkgOptions ghcOpts
+            pkgs `shouldBe` ["Cabal","base","template-haskell"]
+
+        it "uses non default flags" $ do
+            let tdir = "test/data/cabal-flags"
+            _ <- withDirectory_ tdir $
+                readProcess "cabal" ["configure", "-ftest-flag"] ""
+
+            opts <- runD' tdir getGhcOptions
+            let ghcOpts = snd $ head opts
+                pkgs = pkgOptions ghcOpts
+            pkgs `shouldBe` ["Cabal","base"]

test/CheckSpec.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE CPP #-}
 module CheckSpec where
 
-import Data.List (isInfixOf, isPrefixOf) --isSuffixOf,
 import Language.Haskell.GhcMod
---import System.FilePath
+
+import Data.List
+import System.Process
 import Test.Hspec
 
 import TestUtils
@@ -20,6 +21,7 @@ spec = do
 
         it "works even if a module imports another module from a different directory" $ do
             withDirectory_ "test/data/check-test-subdir" $ do
+                _ <- system "cabal configure --enable-tests"
                 res <- runD $ checkSyntax ["test/Bar/Baz.hs"]
                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
 

test/HomeModuleGraphSpec.hs

@@ -0,0 +1,180 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module HomeModuleGraphSpec where
+
+import Language.Haskell.GhcMod.HomeModuleGraph
+import Language.Haskell.GhcMod.Target
+import TestUtils
+
+import GHC
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe
+
+import Test.Hspec
+
+runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a
+runAGhc opts action = withLightHscEnv opts $ \env -> do
+  runLightGhc env $ getSession >>= action
+
+hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph
+hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do
+    runD' dir $ do
+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]
+      homeModuleGraph env smp
+
+uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph
+uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do
+    runD' dir $ do
+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]
+      usmp <- liftIO $ findModulePathSet env [mkModuleName umn]
+      updateHomeModuleGraph env g smp usmp
+
+mapMap :: (Ord k, Ord k')
+  => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a'
+mapMap fk fa = Map.mapKeys fk . Map.map fa
+
+mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath
+mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn)
+
+mp :: ModuleName -> ModulePath
+mp mn = ModulePath mn $ moduleNameString mn ++ ".hs"
+
+spec :: Spec
+spec = do
+    describe "reachable" $ do
+        let
+            smp =
+              Set.fromList
+                [ mp "A"
+                , mp "B"
+                , mp "C"
+                , mp "D"
+                , mp "E"
+                , mp "F"
+                , mp "G"
+                , mp "H"
+                , mp "I"
+                ]
+            fileMap = mkFileMap smp
+            moduleMap = mkModuleMap smp
+
+            completeGraph =
+                Map.map (Set.map lookupMM) . Map.mapKeys lookupMM
+
+            lookupMM = fromJust . flip Map.lookup moduleMap
+
+            graph = completeGraph $
+              Map.fromList
+                [ ("A", Set.fromList ["B"])
+                , ("B", Set.fromList ["C", "D"])
+                , ("C", Set.fromList ["F"])
+                , ("D", Set.fromList ["E"])
+                , ("E", Set.fromList [])
+                , ("F", Set.fromList [])
+                , ("G", Set.fromList [])
+                , ("H", Set.fromList [])
+                , ("I", Set.fromList [])
+                ]
+
+            really_reachable =
+              Set.fromList
+                [ mp "A"
+                , mp "B"
+                , mp "C"
+                , mp "D"
+                , mp "E"
+                , mp "F"
+                ]
+
+            g = GmModuleGraph {
+               gmgFileMap   = fileMap,
+               gmgModuleMap = moduleMap,
+               gmgGraph     = graph
+             }
+
+        it "reachable Set.empty g == Set.empty" $ do
+            reachable Set.empty g `shouldBe` Set.empty
+
+        it "lists only reachable nodes" $ do
+            reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable
+
+
+    describe "homeModuleGraph" $ do
+        it "cycles don't break it" $ do
+            let tdir = "test/data/home-module-graph/cycle"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [mp "A"])
+                ]
+
+        it "follows imports" $ do
+            let tdir = "test/data/home-module-graph/indirect"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [mp "B"])
+                , (mp "A2", Set.fromList [mp "C"])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                , (mp "C",  Set.fromList [])
+                ]
+
+        it "returns partial results on parse errors" $ do
+            let tdir = "test/data/home-module-graph/errors"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [])  -- parse error here
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                ]
+
+        it "returns partial results on CPP errors" $ do
+            let tdir = "test/data/home-module-graph/cpp"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [])  -- CPP error here
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                ]
+
+    describe "updateHomeModuleGraph" $ do
+        it "removes unreachable nodes" $ do
+            let tdir = "test/data/home-module-graph/indirect"
+            let tdir' = "test/data/home-module-graph/indirect-update"
+            ig <- hmGraph tdir [] "A"
+            g <- uhmGraph tdir' [] "A" "A2" ig
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [mp "B"])
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                -- C was removed
+                ]

test/TargetSpec.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+module TargetSpec where
+
+import Language.Haskell.GhcMod.Target
+import Language.Haskell.GhcMod.Gap
+import Test.Hspec
+
+import TestUtils
+
+import GHC
+import Data.List
+import Data.Maybe
+
+spec :: Spec
+spec = do
+    describe "runLightGhc" $ do
+        it "works at all" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env (return ()) `shouldReturn` ()
+
+        it "has modules in scope" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env $ do
+               dflags <- getSessionDynFlags
+               let i = intersect (listVisibleModuleNames dflags)
+                                 ["Control.Applicative", "Control.Arrow"
+                                 ,"Control.Exception", "GHC.Exts", "GHC.Float"]
+               liftIO $ i `shouldSatisfy` not . null
+
+        it "can get module info" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env $ do
+                mdl <- findModule "Data.List" Nothing
+                mmi <- getModuleInfo mdl
+                liftIO $ isJust mmi `shouldBe` True

test/data/annotations/With.hs

@@ -0,0 +1,6 @@
+module Main where
+
+{-# ANN module ["this", "can", "be", "anything"] #-}
+
+main :: IO ()
+main = putStrLn "Hello world!"

test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf

@@ -0,0 +1,4 @@
+name: Cabal
+version: 1.18.1.3
+id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b
+exposed: True

test/data/cabal-project/Baz.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Baz (baz) where
+import Foo (fooQ)
+
+baz = [fooQ| foo bar baz |]

test/data/cabal-project/Foo.hs

@@ -0,0 +1,9 @@
+module Foo (foo, fooQ) where
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+
+foo :: ExpQ
+foo = stringE "foo"
+
+fooQ :: QuasiQuoter
+fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined

test/data/cabal-project/Info.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
+
+module Info () where
+
+fib :: Int -> Int
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n - 1) + fib (n - 2)

test/data/cabal-project/Main.hs

@@ -0,0 +1,3 @@
+import Bar (bar)
+
+main = putStrLn bar

test/data/cabal-project/cabal.sandbox.config.in

@@ -0,0 +1,25 @@
+-- This is a Cabal package environment file.
+-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.
+-- Please create a 'cabal.config' file in the same directory
+-- if you want to change the default settings for this sandbox.
+
+
+local-repo: @CWD@/test/data/cabal-project/.cabal-sandbox/packages
+logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs
+world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world
+user-install: False
+package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d
+build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log
+
+install-dirs
+  prefix: @CWD@/test/data/cabal-project/.cabal-sandbox
+  bindir: $prefix/bin
+  libdir: $prefix/lib
+  libsubdir: $arch-$os-$compiler/$pkgid
+  libexecdir: $prefix/libexec
+  datadir: $prefix/share
+  datasubdir: $arch-$os-$compiler/$pkgid
+  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid
+  htmldir: $docdir/html
+  haddockdir: $htmldir
+  sysconfdir: $prefix/etc

test/data/cabal-project/cabalapi.cabal

@@ -0,0 +1,67 @@
+Name:                   ghc-mod
+Version:                1.11.3
+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>
+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>
+License:                BSD3
+License-File:           LICENSE
+Homepage:               http://www.mew.org/~kazu/proj/ghc-mod/
+Synopsis:               Happy Haskell programming on Emacs/Vim
+Description:            This packages includes Elisp files
+			and a Haskell command, "ghc-mod".
+			"ghc*.el" enable completion of
+			Haskell symbols on Emacs.
+                        Flymake is also integrated.
+			"ghc-mod" is a backend of "ghc*.el".
+			It lists up all installed modules
+                        or extracts names of functions, classes,
+                        and data declarations.
+                        To use "ghc-mod" on Vim,
+                        see <https://github.com/eagletmt/ghcmod-vim> or
+                        <https://github.com/scrooloose/syntastic>
+Category:               Development
+Cabal-Version:          >= 1.6
+Build-Type:             Simple
+Data-Dir:               elisp
+Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
+                        ghc-flymake.el ghc-command.el ghc-info.el
+                        ghc-ins-mod.el ghc-indent.el
+Executable ghc-mod
+  Main-Is:              GHCMod.hs
+  Other-Modules:        Browse
+                        CabalApi
+                        Cabal
+                        CabalDev
+                        Check
+                        ErrMsg
+                        Flag
+                        GHCApi
+                        GHCChoice
+                        Gap
+                        Info
+                        Lang
+                        Lint
+                        List
+                        Paths_ghc_mod
+                        Types
+  GHC-Options:          -Wall
+  Build-Depends:        base >= 4.0 && < 5
+                      , Cabal >= 1.10
+                      , template-haskell
+
+Test-Suite spec
+  Main-Is:              Spec.hs
+  Hs-Source-Dirs:       test, .
+  Type:                 exitcode-stdio-1.0
+  Other-Modules:        Expectation
+                        BrowseSpec
+                        CabalApiSpec
+                        FlagSpec
+                        LangSpec
+                        LintSpec
+                        ListSpec
+  Build-Depends:        base >= 4.0 && < 5
+                      , Cabal >= 1.10
+
+Source-Repository head
+  Type:                 git
+  Location:             git://github.com/kazu-yamamoto/ghc-mod.git

test/data/cabal-project/subdir1/subdir2/dummy

@@ -0,0 +1 @@
+dummy

test/data/foreign-export/ForeignExport.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module ForeignExport where
+
+import Foreign.C.Types
+
+foreign export ccall foo :: CUInt
+
+foo :: CUInt
+foo = 123

test/data/ghc-mod-check/lib/Data/Foo.hs

@@ -0,0 +1,11 @@
+module Data.Foo where
+
+foo :: Int
+foo = undefined
+
+fibonacci :: Int -> Integer
+fibonacci n = fib 1 0 1
+  where
+    fib m x y
+      | n == m    = y
+      | otherwise = fib (m+1) y (x + y)

test/data/hlint/hlint.hs

@@ -0,0 +1,5 @@
+module Hlist where
+
+main :: IO ()
+main = do
+    putStrLn "Hello, world!"

test/data/home-module-graph/cpp/A.hs

@@ -0,0 +1,4 @@
+module A where
+import A1
+import A2
+import A3

test/data/home-module-graph/cpp/A1.hs

@@ -0,0 +1,4 @@
+{-# LANGUAGE CPP #-}
+module A1 where
+#elif
+import B

test/data/home-module-graph/cpp/A2.hs

@@ -0,0 +1 @@
+module A2 where

test/data/home-module-graph/cpp/A3.hs

@@ -0,0 +1,2 @@
+module A3 where
+import B

test/data/home-module-graph/cpp/B.hs

@@ -0,0 +1 @@
+module B where

test/data/home-module-graph/cycle/A.hs

@@ -0,0 +1,2 @@
+module A where
+import B

test/data/home-module-graph/cycle/B.hs

@@ -0,0 +1,2 @@
+module B where
+import A

test/data/home-module-graph/errors/A.hs

@@ -0,0 +1,4 @@
+module A where
+import A1
+import A2
+import A3

test/data/home-module-graph/errors/A1.hs

@@ -0,0 +1,4 @@
+module A1 where
+psogduapzsü9
+import B
+lxäö,vLMCks

test/data/home-module-graph/errors/A2.hs

@@ -0,0 +1 @@
+module A2 where

test/data/home-module-graph/errors/A3.hs

@@ -0,0 +1,2 @@
+module A3 where
+import B

test/data/home-module-graph/errors/B.hs

@@ -0,0 +1 @@
+module B where

test/data/home-module-graph/indirect-update/A.hs

@@ -0,0 +1,4 @@
+module A where
+import A1
+import A2
+import A3

test/data/home-module-graph/indirect-update/A1.hs

@@ -0,0 +1,2 @@
+module A1 where
+import B

test/data/home-module-graph/indirect-update/A2.hs

@@ -0,0 +1 @@
+module A2 where

test/data/home-module-graph/indirect-update/A3.hs

@@ -0,0 +1,2 @@
+module A3 where
+import B

test/data/home-module-graph/indirect-update/B.hs

@@ -0,0 +1 @@
+module B where

test/data/home-module-graph/indirect-update/C.hs

@@ -0,0 +1 @@
+module C where

test/data/home-module-graph/indirect/A.hs

@@ -0,0 +1,4 @@
+module A where
+import A1
+import A2
+import A3

test/data/home-module-graph/indirect/A1.hs

@@ -0,0 +1,2 @@
+module A1 where
+import B

test/data/home-module-graph/indirect/A2.hs

@@ -0,0 +1,2 @@
+module A2 where
+import C

test/data/home-module-graph/indirect/A3.hs

@@ -0,0 +1,2 @@
+module A3 where
+import B

test/data/home-module-graph/indirect/B.hs

@@ -0,0 +1 @@
+module B where

test/data/home-module-graph/indirect/C.hs

@@ -0,0 +1 @@
+module C where

test/data/import-cycle/Mutual1.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
+
+module Mutual1 where
+
+import Mutual2

test/data/import-cycle/Mutual2.hs

@@ -0,0 +1,3 @@
+module Mutual2 where
+
+import Mutual1

test/data/non-exported/Fib.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
+
+module Fib () where
+
+fib :: Int -> Int
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n - 1) + fib (n - 2)

test/data/quasi-quotes/FooQ.hs

@@ -0,0 +1,6 @@
+module FooQ (fooQ) where
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+
+fooQ :: QuasiQuoter
+fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined

test/data/quasi-quotes/QuasiQuotes.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE QuasiQuotes #-}
+module QuasiQuotes where
+
+import FooQ
+
+bar = [fooQ| foo bar baz |]

test/data/template-haskell/Bar.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bar (bar) where
+import Foo (foo)
+
+bar = $foo ++ "bar"

test/data/template-haskell/Foo.hs

@@ -0,0 +1,9 @@
+module Foo (foo, fooQ) where
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+
+foo :: ExpQ
+foo = stringE "foo"
+
+fooQ :: QuasiQuoter
+fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined

test/data/template-haskell/ImportsTH.hs

@@ -0,0 +1,3 @@
+import Bar (bar)
+
+main = putStrLn bar

test/doctests.hs

@@ -1,11 +1,13 @@
+{-# LANGUAGE CPP #-}
 module Main where
 
 import Test.DocTest
 
 main :: IO ()
-main = doctest [
-    "-package"
-  , "ghc"
+main = doctest
+  [ "-package", "ghc"
+  , "-package", "transformers-" ++ VERSION_transformers
+  , "-package", "directory-" ++ VERSION_directory
   , "-XConstraintKinds", "-XFlexibleContexts", "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns"
   , "-idist/build/autogen/"
   , "-optP-include"