New method to check Template Haskell.
This commit is contained in:
Kazu Yamamoto
parent
9e54c8c87b
commit
539fd305bd
35
CabalApi.hs
35
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])
|
||||
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 @@ 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])
|
||||
|
||||
7
Check.hs
7
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
|
||||
|
||||
15
Debug.hs
15
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, [], [], [])
|
||||
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
|
||||
|
||||
57
GHCApi.hs
57
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 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 @@ 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
|
||||
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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
||||
4
Info.hs
4
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user