extract Extensions: and Default-Language: from a Cabal file.

Cabal.hs

@@ -3,15 +3,18 @@
 module Cabal (initializeGHC) where
 
 import Control.Applicative
+import Control.Exception
 import Control.Monad
 import CoreMonad
 import Data.List
+import Data.Maybe
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Parse (readPackageDescription)
 import Distribution.Verbosity (silent)
 import ErrMsg
 import GHC
 import GHCApi
+import Language.Haskell.Extension
 import System.Directory
 import System.FilePath
 import Types
@@ -22,38 +25,47 @@ importDirs :: [String]
 importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
 
 initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
-initializeGHC opt fileName ghcOptions logging = do
+initializeGHC opt fileName ghcOptions logging =
-    (owdir,mdirfile) <- liftIO getDirs
+    withCabal `gcatch` withoutCabal
-    case mdirfile of
+  where
-        Nothing -> do
+    withoutCabal :: SomeException -> Ghc (FilePath,LogReader)
-            logReader <- initSession opt ghcOptions importDirs logging
+    withoutCabal _ = do
-            return (fileName,logReader)
+        logReader <- initSession opt ghcOptions importDirs logging
-        Just (cdir,cfile) -> do
+        return (fileName,logReader)
-            midirs <- parseCabalFile cfile
+    withCabal = do
-            changeToCabalDirectory cdir
+        (owdir,cdir,cfile) <- liftIO getDirs
-            let idirs = case midirs of
+        binfo <- parseCabalFile cfile
-                    []   -> [cdir,owdir]
+        let (idirs',exts',mlang) = extractBuildInfo binfo
-                    dirs -> dirs ++ [owdir]
+            exts = map addX exts'
-                file = ajustFileName fileName owdir cdir
+            lang = maybe "-XHaskell98" addX mlang
-            logReader <- initSession opt ghcOptions idirs logging
+            gopts = ghcOptions ++ exts ++ [lang]
-            return (file,logReader)
+        changeToCabalDirectory cdir
+        let idirs = case idirs' of
+                []   -> [cdir,owdir]
+                dirs -> dirs ++ [owdir]
+            file = ajustFileName fileName owdir cdir
+        logReader <- initSession opt gopts idirs logging
+        return (file,logReader)
+    addX x = "-X" ++ show x
 
 ----------------------------------------------------------------
 
-parseCabalFile :: FilePath -> Ghc [String]
+-- Causes error, catched in the upper function.
+parseCabalFile :: FilePath -> Ghc BuildInfo
 parseCabalFile file = do
     cabal <- liftIO $ readPackageDescription silent file
-    return $ fromLibrary cabal ||| fromExecutable cabal
+    return . fromJust $ fromLibrary cabal >> fromExecutable cabal
   where
-    [] ||| y = y
+    fromLibrary c     = libBuildInfo . condTreeData <$> condLibrary c
-    x  ||| _ = x
+    fromExecutable c  = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c)
-    fromLibrary c = case condLibrary c of
+    toMaybe [] = Nothing
-        Nothing  -> []
+    toMaybe (x:_) = Just x
-        Just lib -> libHsSourceDir lib
+
-    libHsSourceDir = hsSourceDirs . libBuildInfo . condTreeData
+-- SourceDirs, Extensions, and Language
-    fromExecutable = execHsSrouceDir . condExecutables
+extractBuildInfo :: BuildInfo -> ([String],[Extension],Maybe Language)
-    execHsSrouceDir [] = []
+extractBuildInfo binfo = (hsSourceDirs binfo
-    execHsSrouceDir (x:_) = hsSourceDirs . buildInfo . condTreeData . snd $ x
+                         ,oldExtensions binfo
+                         ,defaultLanguage binfo)
 
 ----------------------------------------------------------------
 
@@ -70,25 +82,23 @@ changeToCabalDirectory dir = do
     liftIO $ setCurrentDirectory dir
     workingDirectoryChanged
 
-getDirs :: IO (FilePath, Maybe (FilePath,FilePath))
+-- CurrentWorkingDir, CabalDir, CabalFile
+getDirs :: IO (FilePath,FilePath,FilePath)
 getDirs = do
     wdir <- getCurrentDirectory
-    mcabdir <- cabalDir wdir
+    (cdir,cfile) <- cabalDir wdir
-    case mcabdir of
+    return (wdir,cdir,cfile)
-        Nothing -> return (wdir,Nothing)
-        jdf     -> return (wdir,jdf)
 
-cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
+-- Causes error, catched in the upper function.
+-- CabalDir, CabalFile
+cabalDir :: FilePath -> IO (FilePath,FilePath)
 cabalDir dir = do
     cnts <- (filter isCabal <$> getDirectoryContents dir)
             >>= filterM (\file -> doesFileExist (dir </> file))
+    let dir' = takeDirectory dir
     case cnts of
-        [] -> do
+        [] | dir' == dir -> throwIO $ userError "No cabal file"
-            let dir' = takeDirectory dir
+           | otherwise   -> cabalDir dir'
-            if dir' == dir
+        cfile:_          -> return (dir,dir </> cfile)
-               then return Nothing
-               else cabalDir dir'
-        cfile:_ -> return (Just (dir,dir </> cfile))
   where
-    isCabal name = ".cabal" `isSuffixOf` name
+    isCabal name = ".cabal" `isSuffixOf` name && length name > 6
-                && length name > 6

Check.hs

@@ -25,4 +25,4 @@ check opt fileName = withGHC $ checkIt `gcatch` handleErrMsg
         setTargetFile file
         load LoadAllTargets
         liftIO readLog
-    options = ["-Wall","-fno-warn-unused-do-bind", "-XHaskell98"] ++ ghcOpts opt
+    options = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt