From 9a6c960d530eb3b1fc0bfe8f7269cd79b55450e1 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 1 Mar 2013 21:17:52 +0900 Subject: [PATCH] Checking TH to see if "-fno-code" can be used. --- Cabal.hs | 31 ++++++----------------- CabalApi.hs | 13 +++++----- Check.hs | 1 - GHCApi.hs | 64 +++++++++++++++++++++++++++++++++++------------ Info.hs | 3 +-- Types.hs | 6 +++++ test/CabalSpec.hs | 4 +-- 7 files changed, 72 insertions(+), 50 deletions(-) diff --git a/Cabal.hs b/Cabal.hs index a892df2..a7b72e8 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -1,40 +1,24 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} -module Cabal (initializeGHC, getDirs, fromCabal) where +module Cabal (getDirs, fromCabal) where import CabalApi import Control.Applicative import Control.Exception import Control.Monad -import CoreMonad import Data.List import Distribution.PackageDescription (BuildInfo(..), usedExtensions) import Distribution.Text (display) -import ErrMsg -import GHC -import GHCApi -import GHCChoice import System.Directory import System.FilePath import Types ---------------------------------------------------------------- -importDirs :: [String] -importDirs = [".","..","../..","../../..","../../../..","../../../../.."] - -initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc LogReader -initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal - where - withoutCabal = do - logReader <- initSession opt ghcOptions importDirs Nothing logging - return logReader - withCabal = do - (gopts,idirs,depPkgs) <- liftIO $ fromCabal ghcOptions - logReader <- initSession opt gopts idirs (Just depPkgs) logging - return logReader - -fromCabal :: [String] -> IO ([String], [FilePath], [String]) +fromCabal :: [GHCOption] -> IO ([GHCOption] + ,[IncludeDir] + ,[Package] + ,[LangExt]) fromCabal ghcOptions = do (owdir,cdir,cfile) <- getDirs cabal <- cabalParseFile cfile @@ -48,10 +32,11 @@ fromCabal ghcOptions = do [] -> [cdir,owdir] dirs -> map (cdir ) dirs ++ [owdir] let depPkgs = removeMe cfile $ cabalAllDependPackages cabal - return (gopts,idirs,depPkgs) + hdrExts = cabalAllExtentions cabal + return (gopts,idirs,depPkgs,hdrExts) removeMe :: FilePath -> [String] -> [String] -removeMe cabalfile depPkgs = filter (/= me) depPkgs +removeMe cabalfile = filter (/= me) where me = dropExtension $ takeFileName cabalfile diff --git a/CabalApi.hs b/CabalApi.hs index 2cb28af..b2fd58e 100644 --- a/CabalApi.hs +++ b/CabalApi.hs @@ -6,7 +6,7 @@ module CabalApi ( ) where import Control.Applicative -import Data.Maybe (fromJust, maybeToList, catMaybes) +import Data.Maybe (fromJust, maybeToList, mapMaybe) import Data.Set (fromList, toList) import Distribution.Package (Dependency(Dependency), PackageName(PackageName)) import Distribution.PackageDescription @@ -14,6 +14,7 @@ import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Text (display) import Distribution.Verbosity (silent) import Language.Haskell.Extension (Extension(..)) +import Types ---------------------------------------------------------------- @@ -33,7 +34,7 @@ cabalBuildInfo pd = fromJust $ fromLibrary pd <|> fromExecutable pd ---------------------------------------------------------------- -cabalAllDependPackages :: GenericPackageDescription -> [String] +cabalAllDependPackages :: GenericPackageDescription -> [Package] cabalAllDependPackages pd = uniqueAndSort pkgs where pkgs = map getDependencyPackageName $ cabalAllDependency pd @@ -44,20 +45,20 @@ cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps getDeps :: [Tree a] -> [Dependency] getDeps = concatMap condTreeConstraints -getDependencyPackageName :: Dependency -> String +getDependencyPackageName :: Dependency -> Package getDependencyPackageName (Dependency (PackageName nm) _) = nm ---------------------------------------------------------------- -cabalAllExtentions :: GenericPackageDescription -> [String] +cabalAllExtentions :: GenericPackageDescription -> [LangExt] cabalAllExtentions pd = uniqueAndSort exts where buildInfos = cabalAllBuildInfos pd eexts = concatMap oldExtensions buildInfos ++ concatMap defaultExtensions buildInfos - exts = catMaybes $ map getExtensionName eexts + exts = mapMaybe getExtensionName eexts -getExtensionName :: Extension -> Maybe String +getExtensionName :: Extension -> Maybe LangExt getExtensionName (EnableExtension nm) = Just (display nm) getExtensionName _ = Nothing diff --git a/Check.hs b/Check.hs index a3b831d..e8428ec 100644 --- a/Check.hs +++ b/Check.hs @@ -1,6 +1,5 @@ module Check (checkSyntax) where -import Cabal import Control.Applicative import CoreMonad import ErrMsg diff --git a/GHCApi.hs b/GHCApi.hs index 259b769..3397508 100644 --- a/GHCApi.hs +++ b/GHCApi.hs @@ -1,5 +1,6 @@ module GHCApi where +import Cabal import Control.Applicative import Control.Exception import CoreMonad @@ -8,6 +9,8 @@ import ErrMsg import Exception import GHC import GHC.Paths (libdir) +import GHCChoice +import HeaderInfo import System.Exit import System.IO import Types @@ -34,36 +37,65 @@ initSession0 :: Options -> Ghc [PackageId] initSession0 opt = getSessionDynFlags >>= (>>= setSessionDynFlags) . setGhcFlags opt -initSession :: Options -> [String] -> [FilePath] -> Maybe [String] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs mayPkgs logging = do +---------------------------------------------------------------- + +importDirs :: [IncludeDir] +importDirs = [".","..","../..","../../..","../../../..","../../../../.."] + +initializeGHC :: Options -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader +initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal + where + withoutCabal = initSession opt ghcOptions importDirs Nothing Nothing logging fileName + withCabal = do + (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabal ghcOptions + initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName + +initSession :: Options + -> [GHCOption] + -> [IncludeDir] + -> Maybe [Package] + -> Maybe [LangExt] + -> Bool + -> FilePath + -> Ghc LogReader +initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do dflags <- getSessionDynFlags - let opts = map noLoc cmdOpts + hdrExts <- liftIO $ map unLoc <$> getOptionsFromFile dflags file + let th = useTemplateHaskell mLangExts hdrExts + opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts (dflags'',readLog) <- liftIO . (>>= setLogger logging) - . setGhcFlags opt . setFlags opt dflags' idirs $ mayPkgs + . setGhcFlags opt . setFlags opt dflags' idirs mDepPkgs $ th _ <- setSessionDynFlags dflags'' return readLog +useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool +useTemplateHaskell mLangExts hdrExts = th1 || th2 + where + th1 = "-XTemplateHaskell" `elem` hdrExts + th2 = maybe False ("TemplateHaskell" `elem`) mLangExts + ---------------------------------------------------------------- -setFlags :: Options -> DynFlags -> [FilePath] -> Maybe [String] -> DynFlags -setFlags opt d idirs mayPkgs +setFlags :: Options -> DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> DynFlags +setFlags opt d idirs mDepPkgs th | expandSplice opt = dopt_set d' Opt_D_dump_splices | otherwise = d' where - d' = maySetExpose $ d { + d' = addDevPkgs mDepPkgs $ d { importPaths = idirs - , ghcLink = LinkInMemory - , hscTarget = HscInterpreted - , flags = flags d + , ghcLink = if th then LinkInMemory else NoLink + , hscTarget = if th then HscInterpreted else HscNothing + , flags = flags d } - -- Do hide-all only when depend packages specified - maySetExpose df = maybe df (\x -> (dopt_set df Opt_HideAllPackages) { - packageFlags = map ExposePackage x ++ packageFlags df - }) mayPkgs -ghcPackage :: PackageFlag -ghcPackage = ExposePackage "ghc" +addDevPkgs :: Maybe [Package] -> DynFlags -> DynFlags +addDevPkgs Nothing df = df +addDevPkgs (Just pkgs) df = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df + } + where + df' = dopt_set df Opt_HideAllPackages setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags setGhcFlags opt flagset = diff --git a/Info.hs b/Info.hs index c487d77..d657a23 100644 --- a/Info.hs +++ b/Info.hs @@ -3,7 +3,6 @@ module Info (infoExpr, typeExpr) where -import Cabal import Control.Applicative import CoreUtils import Data.Function @@ -23,8 +22,8 @@ import NameSet import Outputable import PprTyThing import Pretty (showDocWith, Mode(OneLineMode)) -import TcRnTypes import TcHsSyn (hsPatType) +import TcRnTypes import Types ---------------------------------------------------------------- diff --git a/Types.hs b/Types.hs index 13b515d..45bb3ca 100644 --- a/Types.hs +++ b/Types.hs @@ -61,3 +61,9 @@ quote x = "\"" ++ x ++ "\"" addNewLine :: String -> String addNewLine = (++ "\n") + +type GHCOption = String +type IncludeDir = FilePath +type Package = String +type LangExt = String +type HeaderExt = String \ No newline at end of file diff --git a/test/CabalSpec.hs b/test/CabalSpec.hs index 0be2427..d9f1291 100644 --- a/test/CabalSpec.hs +++ b/test/CabalSpec.hs @@ -19,5 +19,5 @@ spec = do it "obtains two directories and a cabal file" $ do len <- length <$> getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ do - (x,y,z) <- fromCabal [] - (x, map (drop len) y, z) `shouldBe` (["-XHaskell98"],["/test/data","/test/data/subdir1/subdir2"],["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"]) + (x,y,z,w) <- fromCabal [] + (x, map (drop len) y, z, w) `shouldBe` (["-XHaskell98"],["/test/data","/test/data/subdir1/subdir2"],["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"], [])