New method to check Template Haskell.

CabalApi.hs

@@ -5,14 +5,13 @@ module CabalApi (
   , 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.Simple.Program.Types (programName, programFindVersion)
 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 @@ import Types
 
 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])
+            -> ([GHCOption],[IncludeDir],[Package])
-cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts)
+cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs)
   where
     owdir      = cradleCurrentDir cradle
     Just cdir  = cradleCabalDir   cradle
@@ -47,7 +45,6 @@ cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts)
     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)
@@ -98,30 +95,6 @@ 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)
-
-----------------------------------------------------------------
-
 type Tree = CondTree ConfVar [Dependency]
 
 fromPackageDescription :: ([Tree Library]    -> [a])

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,11 @@ check :: Options -> Cradle -> String -> IO [String]
 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
+        slow <- needsTemplateHaskell <$> depanal [] False
+        when slow setSlowDynFlags
+        void $ load LoadAllTargets
         liftIO readLog
     options
       | expandSplice opt = "-w:"   : ghcOpts opt

Debug.hs

@@ -1,10 +1,12 @@
 module Debug (debugInfo) 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 @@ debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName
 
 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, [], [], [])
+            return (ghcOpts opt, [], [])
-    dflags <- getDynamicFlags
+    [fast] <- withGHC fileName $ do
-    fast <- getFastCheck dflags fileName (Just langext)
+        void $ initializeFlagsWithCradle opt cradle gopts True
+        setTargetFile fileName
+        slow <- needsTemplateHaskell <$> depanal [] False
+        return [not slow]
     return [
         "GHC version:         " ++ ver
       , "Current directory:   " ++ currentDir

GHCApi.hs

@@ -5,7 +5,7 @@ module GHCApi (
   , initializeFlagsWithCradle
   , setTargetFile
   , getDynamicFlags
-  , getFastCheck
+  , setSlowDynFlags
   ) where
 
 import CabalApi
@@ -19,7 +19,6 @@ import ErrMsg
 import Exception
 import GHC
 import GHC.Paths (libdir)
-import HeaderInfo
 import System.Exit
 import System.IO
 import Types
@@ -45,13 +44,13 @@ withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do
 importDirs :: [IncludeDir]
 importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
 
-initializeFlagsWithCradle :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader
+initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader
-initializeFlagsWithCradle opt cradle fileName ghcOptions logging
+initializeFlagsWithCradle opt cradle ghcOptions logging
   | cabal     = do
-      (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabalFile ghcOptions cradle
+      (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle
-      initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName
+      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 @@ initSession :: Options
             -> [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 @@ initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do
   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 @@ initializeFlags opt = do
 
 ----------------------------------------------------------------
 
-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 @@ modifyFlags d0 idirs mDepPkgs fast splice
 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 @@ setFastOrNot dflags True = dflags {
   , hscTarget = HscNothing
   }
 
-addDevPkgs :: DynFlags -> [Package] -> DynFlags
+setSlowDynFlags :: Ghc ()
-addDevPkgs df pkgs = df''
+setSlowDynFlags = (flip setFastOrNot False <$> getSessionDynFlags)
-  where
+                  >>= void . setSessionDynFlags
-    df' = dopt_set df Opt_HideAllPackages
-    df'' = df' {
-        packageFlags = map ExposePackage pkgs ++ packageFlags df
-      }
 
 ----------------------------------------------------------------
 

Info.hs

@@ -143,12 +143,12 @@ inModuleContext opt cradle fileName modstr action errmsg =
     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

Types.hs

@@ -76,5 +76,3 @@ data Cradle = Cradle {
 type GHCOption  = String
 type IncludeDir = FilePath
 type Package    = String
-type LangExt    = String
-type HeaderExt  = String