diff --git a/Browse.hs b/Browse.hs --- a/Browse.hs +++ b/Browse.hs @@ -4,16 +4,16 @@ import Data.Char import Data.List import Data.Maybe (fromMaybe) +import DataCon (dataConRepType) +import Doc import GHC import GHCApi -import Gap import Name import Outputable import TyCon import Type import Types import Var -import DataCon (dataConRepType) ---------------------------------------------------------------- @@ -55,20 +55,21 @@ tyInfo <- modInfoLookupName minfo nm -- If nothing found, load dependent module and lookup global tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo - return $ fromMaybe (getOccString nm) (tyResult >>= showThing) + dflag <- getSessionDynFlags + return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag) inOtherModule :: Name -> Ghc (Maybe TyThing) inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm -showThing :: TyThing -> Maybe String -showThing (AnId i) = Just $ formatType varType i -showThing (ADataCon d) = Just $ formatType dataConRepType d -showThing (ATyCon t) = unwords . toList <$> tyType t +showThing :: DynFlags -> TyThing -> Maybe String +showThing dflag (AnId i) = Just $ formatType dflag varType i +showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d +showThing _ (ATyCon t) = unwords . toList <$> tyType t where toList t' = t' : getOccString t : map getOccString (tyConTyVars t) -showThing _ = Nothing +showThing _ _ = Nothing -formatType :: NamedThing a => (a -> Type) -> a -> String -formatType f x = getOccString x ++ " :: " ++ showOutputable (removeForAlls $ f x) +formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String +formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x) tyType :: TyCon -> Maybe String tyType typ @@ -92,5 +93,5 @@ | isPredTy pre = mkFunTy pre (dropForAlls ftype) | otherwise = ty -showOutputable :: Outputable a => a -> String -showOutputable = unwords . lines . showDocForUser neverQualify . ppr +showOutputable :: Outputable a => DynFlags -> a -> String +showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr diff --git a/CabalApi.hs b/CabalApi.hs --- a/CabalApi.hs +++ b/CabalApi.hs @@ -5,14 +5,13 @@ , cabalParseFile , cabalBuildInfo , cabalAllDependPackages - , cabalAllExtentions , getGHCVersion ) where import Control.Applicative import Control.Exception (throwIO) import Data.List (intercalate) -import Data.Maybe (fromJust, maybeToList, mapMaybe) +import Data.Maybe (fromJust, maybeToList) import Data.Set (fromList, toList) import Distribution.Package (Dependency(Dependency), PackageName(PackageName)) import Distribution.PackageDescription @@ -22,7 +21,6 @@ import Distribution.Text (display) import Distribution.Verbosity (silent) import Distribution.Version (versionBranch) -import Language.Haskell.Extension (Extension(..)) import System.FilePath import Types @@ -30,15 +28,15 @@ fromCabalFile :: [GHCOption] -> Cradle - -> IO ([GHCOption],[IncludeDir],[Package],[LangExt]) + -> IO ([GHCOption],[IncludeDir],[Package]) fromCabalFile ghcOptions cradle = cookInfo ghcOptions cradle <$> cabalParseFile cfile where Just cfile = cradleCabalFile cradle cookInfo :: [String] -> Cradle -> GenericPackageDescription - -> ([GHCOption],[IncludeDir],[Package],[LangExt]) -cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts) + -> ([GHCOption],[IncludeDir],[Package]) +cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs) where owdir = cradleCurrentDir cradle Just cdir = cradleCabalDir cradle @@ -47,7 +45,6 @@ gopts = getGHCOptions ghcOptions binfo idirs = includeDirectroies cdir owdir $ hsSourceDirs binfo depPkgs = removeMe cfile $ cabalAllDependPackages cabal - hdrExts = cabalAllExtentions cabal removeMe :: FilePath -> [String] -> [String] removeMe cabalfile = filter (/= me) @@ -95,30 +92,6 @@ getDependencyPackageName :: Dependency -> Package getDependencyPackageName (Dependency (PackageName nm) _) = nm - ----------------------------------------------------------------- - -cabalAllExtentions :: GenericPackageDescription -> [LangExt] -cabalAllExtentions pd = uniqueAndSort exts - where - buildInfos = cabalAllBuildInfos pd - eexts = concatMap oldExtensions buildInfos - ++ concatMap defaultExtensions buildInfos - exts = mapMaybe getExtensionName eexts - -getExtensionName :: Extension -> Maybe LangExt -getExtensionName (EnableExtension nm) = Just (display nm) -getExtensionName _ = Nothing - ----------------------------------------------------------------- - -cabalAllBuildInfos :: GenericPackageDescription -> [BuildInfo] -cabalAllBuildInfos = fromPackageDescription f1 f2 f3 f4 - where - f1 = map (libBuildInfo . condTreeData) - f2 = map (buildInfo . condTreeData) - f3 = map (testBuildInfo . condTreeData) - f4 = map (benchmarkBuildInfo . condTreeData) ---------------------------------------------------------------- diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -1,6 +1,7 @@ module Check (checkSyntax) where import Control.Applicative +import Control.Monad import CoreMonad import ErrMsg import Exception @@ -20,9 +21,15 @@ check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg where checkIt = do - readLog <- initializeFlagsWithCradle opt cradle fileName options True + readLog <- initializeFlagsWithCradle opt cradle options True setTargetFile fileName - _ <- load LoadAllTargets + -- To check TH, a session module graph is necessary. + -- "load" sets a session module graph using "depanal". + -- But we have to set "-fno-code" to DynFlags before "load". + -- So, this is necessary redundancy. + slow <- needsTemplateHaskell <$> depanal [] False + when slow setSlowDynFlags + void $ load LoadAllTargets liftIO readLog options | expandSplice opt = "-w:" : ghcOpts opt diff --git a/Debug.hs b/Debug.hs --- a/Debug.hs +++ b/Debug.hs @@ -1,10 +1,12 @@ -module Debug (debugInfo) where +module Debug (debugInfo, debug) where import CabalApi -import GHCApi import Control.Applicative +import Control.Monad import Data.List (intercalate) import Data.Maybe +import GHC +import GHCApi import Prelude import Types @@ -15,13 +17,16 @@ debug :: Options -> Cradle -> String -> String -> IO [String] debug opt cradle ver fileName = do - (gopts, incDir, pkgs, langext) <- + (gopts, incDir, pkgs) <- if cabal then fromCabalFile (ghcOpts opt) cradle else - return (ghcOpts opt, [], [], []) - dflags <- getDynamicFlags - fast <- getFastCheck dflags fileName (Just langext) + return (ghcOpts opt, [], []) + [fast] <- withGHC fileName $ do + void $ initializeFlagsWithCradle opt cradle gopts True + setTargetFile fileName + slow <- needsTemplateHaskell <$> depanal [] False + return [not slow] return [ "GHC version: " ++ ver , "Current directory: " ++ currentDir diff --git a/Doc.hs b/Doc.hs new file mode 100644 --- /dev/null +++ b/Doc.hs @@ -0,0 +1,24 @@ +module Doc where + +import DynFlags (DynFlags) +import Gap (withStyle) +import Outputable +import Pretty + +styleQualified :: PprStyle +styleQualified = mkUserStyle alwaysQualify AllTheWay + +styleUnqualified :: PprStyle +styleUnqualified = mkUserStyle neverQualify AllTheWay + +showQualifiedPage :: DynFlags -> SDoc -> String +showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified + +showUnqualifiedPage :: DynFlags -> SDoc -> String +showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified + +showQualifiedOneLine :: DynFlags -> SDoc -> String +showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified + +showUnqualifiedOneLine :: DynFlags -> SDoc -> String +showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified diff --git a/ErrMsg.hs b/ErrMsg.hs --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -8,6 +8,7 @@ import Control.Applicative import Data.IORef import Data.Maybe +import Doc import DynFlags import ErrUtils import GHC @@ -31,27 +32,29 @@ let newdf = Gap.setLogAction df $ appendLog ref return (newdf, reverse <$> readIORef ref) where - appendLog ref _ sev src stl msg = modifyIORef ref (\ls -> ppMsg src sev msg stl : ls) + appendLog ref _ sev src _ msg = modifyIORef ref (\ls -> ppMsg src sev df msg : ls) ---------------------------------------------------------------- handleErrMsg :: SourceError -> Ghc [String] -handleErrMsg = return . errBagToStrList . srcErrorMessages +handleErrMsg err = do + dflag <- getSessionDynFlags + return . errBagToStrList dflag . srcErrorMessages $ err -errBagToStrList :: Bag ErrMsg -> [String] -errBagToStrList = map ppErrMsg . reverse . bagToList +errBagToStrList :: DynFlags -> Bag ErrMsg -> [String] +errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList ---------------------------------------------------------------- -ppErrMsg :: ErrMsg -> String -ppErrMsg err = ppMsg spn SevError msg defaultUserStyle ++ ext +ppErrMsg :: DynFlags -> ErrMsg -> String +ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext where spn = head (errMsgSpans err) msg = errMsgShortDoc err - ext = showMsg (errMsgExtraInfo err) defaultUserStyle + ext = showMsg dflag (errMsgExtraInfo err) -ppMsg :: SrcSpan -> Severity-> SDoc -> PprStyle -> String -ppMsg spn sev msg stl = fromMaybe def $ do +ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String +ppMsg spn sev dflag msg = fromMaybe def $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- normalise <$> Gap.getSrcFile spn let severityCaption = Gap.showSeverityCaption sev @@ -59,12 +62,12 @@ ++ show col ++ ":" ++ severityCaption ++ cts ++ "\0" where def = "ghc-mod:0:0:Probably mutual module import occurred\0" - cts = showMsg msg stl + cts = showMsg dflag msg ---------------------------------------------------------------- -showMsg :: SDoc -> PprStyle -> String -showMsg d stl = map toNull $ Gap.renderMsg d stl +showMsg :: DynFlags -> SDoc -> String +showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc where toNull '\n' = '\0' toNull x = x diff --git a/GHCApi.hs b/GHCApi.hs --- a/GHCApi.hs +++ b/GHCApi.hs @@ -5,7 +5,7 @@ , initializeFlagsWithCradle , setTargetFile , getDynamicFlags - , getFastCheck + , setSlowDynFlags ) where import CabalApi @@ -19,7 +19,6 @@ import Exception import GHC import GHC.Paths (libdir) -import HeaderInfo import System.Exit import System.IO import Types @@ -45,13 +44,13 @@ importDirs :: [IncludeDir] importDirs = [".","..","../..","../../..","../../../..","../../../../.."] -initializeFlagsWithCradle :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader -initializeFlagsWithCradle opt cradle fileName ghcOptions logging +initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader +initializeFlagsWithCradle opt cradle ghcOptions logging | cabal = do - (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabalFile ghcOptions cradle - initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName + (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle + initSession opt gopts idirs (Just depPkgs) logging | otherwise = - initSession opt ghcOptions importDirs Nothing Nothing logging fileName + initSession opt ghcOptions importDirs Nothing logging where cabal = isJust $ cradleCabalFile cradle @@ -61,11 +60,9 @@ -> [GHCOption] -> [IncludeDir] -> Maybe [Package] - -> Maybe [LangExt] -> Bool - -> FilePath -> Ghc LogReader -initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do +initSession opt cmdOpts idirs mDepPkgs logging = do dflags0 <- getSessionDynFlags (dflags1,readLog) <- setupDynamicFlags dflags0 _ <- setSessionDynFlags dflags1 @@ -73,7 +70,7 @@ where setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts - fast <- liftIO $ getFastCheck df0 file mLangExts + let fast = True let df2 = modifyFlags df1 idirs mDepPkgs fast (expandSplice opt) df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt liftIO $ setLogger logging df3 @@ -88,24 +85,6 @@ ---------------------------------------------------------------- -getHeaderExtension :: DynFlags -> FilePath -> IO [HeaderExt] -getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file - ----------------------------------------------------------------- - -getFastCheck :: DynFlags -> FilePath -> Maybe [LangExt] -> IO Bool -getFastCheck dflags file mLangExts = do - hdrExts <- getHeaderExtension dflags file - return . not $ useTemplateHaskell mLangExts hdrExts - -useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool -useTemplateHaskell mLangExts hdrExts = th1 || th2 - where - th1 = "-XTemplateHaskell" `elem` hdrExts - th2 = maybe False ("TemplateHaskell" `elem`) mLangExts - ----------------------------------------------------------------- - -- FIXME removing Options modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Bool -> DynFlags modifyFlags d0 idirs mDepPkgs fast splice @@ -119,6 +98,16 @@ setSplice :: DynFlags -> DynFlags setSplice dflag = dopt_set dflag Opt_D_dump_splices +addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df pkgs = df'' + where + df' = dopt_set df Opt_HideAllPackages + df'' = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df + } + +---------------------------------------------------------------- + setFastOrNot :: DynFlags -> Bool -> DynFlags setFastOrNot dflags False = dflags { ghcLink = LinkInMemory @@ -129,13 +118,9 @@ , hscTarget = HscNothing } -addDevPkgs :: DynFlags -> [Package] -> DynFlags -addDevPkgs df pkgs = df'' - where - df' = dopt_set df Opt_HideAllPackages - df'' = df' { - packageFlags = map ExposePackage pkgs ++ packageFlags df - } +setSlowDynFlags :: Ghc () +setSlowDynFlags = (flip setFastOrNot False <$> getSessionDynFlags) + >>= void . setSessionDynFlags ---------------------------------------------------------------- diff --git a/Gap.hs b/Gap.hs --- a/Gap.hs +++ b/Gap.hs @@ -3,14 +3,11 @@ module Gap ( Gap.ClsInst , mkTarget - , showDocForUser - , showDoc - , styleDoc + , withStyle , setLogAction , supportedExtensions , getSrcSpan , getSrcFile - , renderMsg , setCtx , fOptions , toStringBuffer @@ -77,25 +74,11 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -showDocForUser :: PrintUnqualified -> SDoc -> String -#if __GLASGOW_HASKELL__ >= 706 -showDocForUser = showSDocForUser tracingDynFlags -#else -showDocForUser = showSDocForUser -#endif - -showDoc :: SDoc -> String -#if __GLASGOW_HASKELL__ >= 706 -showDoc = showSDoc tracingDynFlags -#else -showDoc = showSDoc -#endif - -styleDoc :: PprStyle -> SDoc -> Pretty.Doc +withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc #if __GLASGOW_HASKELL__ >= 706 -styleDoc = withPprStyleDoc tracingDynFlags +withStyle = withPprStyleDoc #else -styleDoc = withPprStyleDoc +withStyle _ = withPprStyleDoc #endif setLogAction :: DynFlags @@ -140,17 +123,6 @@ getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn #endif getSrcFile _ = Nothing - ----------------------------------------------------------------- - -renderMsg :: SDoc -> PprStyle -> String -#if __GLASGOW_HASKELL__ >= 706 -renderMsg d stl = renderWithStyle tracingDynFlags d stl -#elif __GLASGOW_HASKELL__ >= 702 -renderMsg d stl = renderWithStyle d stl -#else -renderMsg d stl = Pretty.showDocWith PageMode $ d stl -#endif ---------------------------------------------------------------- diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -12,6 +12,7 @@ import Data.Ord as O import Data.Time.Clock import Desugar +import Doc import GHC import GHC.SYB.Utils import GHCApi @@ -21,7 +22,6 @@ import NameSet import Outputable import PprTyThing -import Pretty (showDocWith, Mode(OneLineMode)) import TcHsSyn (hsPatType) import TcRnTypes import Types @@ -81,11 +81,12 @@ bts <- mapM (getType tcm) bs ets <- mapM (getType tcm) es pts <- mapM (getType tcm) ps - let sss = map toTup $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts] + dflag <- getSessionDynFlags + let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts] return $ convert opt sss - toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String) - toTup (spn, typ) = (fourInts spn, pretty typ) + toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) + toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ) fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan @@ -105,8 +106,8 @@ listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) -pretty :: Type -> String -pretty = showDocWith OneLineMode . Gap.styleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False +pretty :: DynFlags -> Type -> String +pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs @@ -116,14 +117,14 @@ names <- parseName str mb_stuffs <- mapM getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) - unqual <- getPrintUnqual - return $ Gap.showDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + dflag <- getSessionDynFlags + return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered) filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc pprInfo pefas (thing, fixity, insts) @@ -132,8 +133,8 @@ $$ vcat (map pprInstance insts) where show_fixity fx - | fx == defaultFixity = Outputable.empty - | otherwise = ppr fx <+> ppr (getName thing) + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) ---------------------------------------------------------------- @@ -142,18 +143,19 @@ withGHCDummyFile (valid ||> invalid ||> return errmsg) where valid = do - _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False + _ <- initializeFlagsWithCradle opt cradle ["-w"] False setTargetFile fileName _ <- load LoadAllTargets doif setContextFromTarget action invalid = do - _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False + _ <- initializeFlagsWithCradle opt cradle ["-w"] False setTargetBuffer _ <- load LoadAllTargets doif setContextFromTarget action setTargetBuffer = do modgraph <- depanal [mkModuleName modstr] True - let imports = concatMap (map (Gap.showDoc . ppr . unLoc)) $ + dflag <- getSessionDynFlags + let imports = concatMap (map (showQualifiedPage dflag . ppr . unLoc)) $ map ms_imps modgraph ++ map ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports diff --git a/Lint.hs b/Lint.hs --- a/Lint.hs +++ b/Lint.hs @@ -6,9 +6,9 @@ import Types lintSyntax :: Options -> String -> IO String -lintSyntax opt file = pretty <$> lint opt file +lintSyntax opt file = pack <$> lint opt file where - pretty = unlines . map (intercalate "\0" . lines) + pack = unlines . map (intercalate "\0" . lines) lint :: Options -> String -> IO [String] lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -76,5 +76,3 @@ type GHCOption = String type IncludeDir = FilePath type Package = String -type LangExt = String -type HeaderExt = String diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 1.12.1 +Version: 1.12.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -40,6 +40,7 @@ CabalApi Check Cradle + Doc Debug ErrMsg Flag @@ -79,6 +80,7 @@ BrowseSpec CabalApiSpec CheckSpec + DebugSpec FlagSpec InfoSpec LangSpec diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -9,7 +9,7 @@ describe "cabalAllDependPackages" $ do it "extracts dependent packages" $ do pkgs <- cabalAllDependPackages <$> cabalParseFile "test/data/cabalapi.cabal" - pkgs `shouldBe` ["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"] + pkgs `shouldBe` ["Cabal","base","template-haskell"] describe "cabalBuildInfo" $ do it "extracts build info" $ do diff --git a/test/DebugSpec.hs b/test/DebugSpec.hs new file mode 100644 --- /dev/null +++ b/test/DebugSpec.hs @@ -0,0 +1,23 @@ +module DebugSpec where + +import CabalApi +import Cradle +import Debug +import Expectation +import Test.Hspec +import Types + +checkFast :: String -> String -> IO () +checkFast file ans = withDirectory_ "test/data" $ do + (strVer,_) <- getGHCVersion + cradle <- findCradle Nothing strVer + res <- debug defaultOptions cradle strVer file + res `shouldContain` ans + +spec :: Spec +spec = do + describe "debug" $ do + it "can check TH" $ do + checkFast "Main.hs" "Fast check: No" + checkFast "Foo.hs" "Fast check: Yes" + checkFast "Bar.hs" "Fast check: No" diff --git a/test/data/Bar.hs b/test/data/Bar.hs new file mode 100644 --- /dev/null +++ b/test/data/Bar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Bar (bar) where +import Foo (foo) + +bar = $foo ++ "bar" diff --git a/test/data/Foo.hs b/test/data/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/Foo.hs @@ -0,0 +1,5 @@ +module Foo (foo) where +import Language.Haskell.TH + +foo :: ExpQ +foo = stringE "foo" diff --git a/test/data/Main.hs b/test/data/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/Main.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/data/cabalapi.cabal b/test/data/cabalapi.cabal --- a/test/data/cabalapi.cabal +++ b/test/data/cabalapi.cabal @@ -46,21 +46,7 @@ GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 , Cabal >= 1.10 - , containers - , convertible - , directory - , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.7.1 - , io-choice - , old-time - , process - , regex-posix - , syb - , time - , transformers + , template-haskell Test-Suite spec Main-Is: Spec.hs @@ -75,22 +61,6 @@ ListSpec Build-Depends: base >= 4.0 && < 5 , Cabal >= 1.10 - , containers - , convertible - , directory - , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.7.1 - , io-choice - , old-time - , process - , regex-posix - , syb - , time - , transformers - , hspec Source-Repository head Type: git