Changing GHCMod as a library.

2013-05-17 10:00:01 +09:00
parent 1977b8858a
commit bac4bbbcf3
20 changed files with 113 additions and 84 deletions
--- a/Language/Haskell/GhcMod/CabalApi.hs
+++ b/Language/Haskell/GhcMod/CabalApi.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.Haskell.GhcMod.CabalApi (
+    fromCabalFile
+  , cabalParseFile
+  , cabalBuildInfo
+  , cabalAllDependPackages
+  , cabalAllSourceDirs
+  , getGHCVersion
+  ) where
+
+import Control.Applicative
+import Control.Exception (throwIO)
+import Data.List (intercalate)
+import Data.Maybe (maybeToList, listToMaybe)
+import Data.Set (fromList, toList)
+import Distribution.Package (Dependency(Dependency), PackageName(PackageName))
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.Simple.Program (ghcProgram)
+import Distribution.Simple.Program.Types (programName, programFindVersion)
+import Distribution.Text (display)
+import Distribution.Verbosity (silent)
+import Distribution.Version (versionBranch)
+import Language.Haskell.GhcMod.Types
+import System.FilePath
+
+----------------------------------------------------------------
+
+fromCabalFile :: [GHCOption]
+              -> Cradle
+              -> IO ([GHCOption],[IncludeDir],[Package])
+fromCabalFile ghcOptions cradle = do
+    cabal <- cabalParseFile cfile
+    case cabalBuildInfo cabal of
+        Nothing    -> throwIO $ userError "cabal file is broken"
+        Just binfo -> return $ cookInfo ghcOptions cradle cabal binfo
+  where
+    Just cfile = cradleCabalFile cradle
+
+cookInfo :: [String] -> Cradle -> GenericPackageDescription -> BuildInfo
+         -> ([GHCOption],[IncludeDir],[Package])
+cookInfo ghcOptions cradle cabal binfo = (gopts,idirs,depPkgs)
+  where
+    wdir       = cradleCurrentDir cradle
+    Just cdir  = cradleCabalDir   cradle
+    Just cfile = cradleCabalFile  cradle
+    gopts      = getGHCOptions ghcOptions binfo
+    idirs      = includeDirectories cdir wdir $ cabalAllSourceDirs cabal
+    depPkgs    = removeMe cfile $ cabalAllDependPackages cabal
+
+removeMe :: FilePath -> [String] -> [String]
+removeMe cabalfile = filter (/= me)
+  where
+    me = dropExtension $ takeFileName cabalfile
+
+----------------------------------------------------------------
+
+cabalParseFile :: FilePath -> IO GenericPackageDescription
+cabalParseFile = readPackageDescription silent
+
+----------------------------------------------------------------
+
+getGHCOptions :: [String] -> BuildInfo -> [String]
+getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs
+  where
+    exts = map (("-X" ++) . display) $ usedExtensions binfo
+    lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo
+    libs = map ("-l" ++) $ extraLibs binfo
+    libDirs = map ("-L" ++) $ extraLibDirs binfo
+
+----------------------------------------------------------------
+
+-- Causes error, catched in the upper function.
+cabalBuildInfo :: GenericPackageDescription -> Maybe BuildInfo
+cabalBuildInfo pd = fromLibrary pd <|> fromExecutable pd
+  where
+    fromLibrary c    = libBuildInfo . condTreeData <$> condLibrary c
+    fromExecutable c = buildInfo . condTreeData . snd <$> listToMaybe (condExecutables c)
+
+----------------------------------------------------------------
+
+cabalAllSourceDirs :: GenericPackageDescription -> [FilePath]
+cabalAllSourceDirs = fromPackageDescription (f libBuildInfo) (f buildInfo) (f testBuildInfo) (f benchmarkBuildInfo)
+  where
+    f getBuildInfo = concatMap (hsSourceDirs . getBuildInfo . condTreeData)
+
+cabalAllDependPackages :: GenericPackageDescription -> [Package]
+cabalAllDependPackages pd = uniqueAndSort pkgs
+  where
+    pkgs = map getDependencyPackageName $ cabalAllDependency pd
+
+cabalAllDependency :: GenericPackageDescription -> [Dependency]
+cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps
+  where
+    getDeps :: [Tree a] -> [Dependency]
+    getDeps = concatMap condTreeConstraints
+
+getDependencyPackageName :: Dependency -> Package
+getDependencyPackageName (Dependency (PackageName nm) _) = nm
+
+----------------------------------------------------------------
+
+type Tree = CondTree ConfVar [Dependency]
+
+fromPackageDescription :: ([Tree Library]    -> [a])
+                       -> ([Tree Executable] -> [a])
+                       -> ([Tree TestSuite]  -> [a])
+                       -> ([Tree Benchmark]  -> [a])
+                       -> GenericPackageDescription
+                       -> [a]
+fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench
+  where
+    lib   = f1 . maybeToList . condLibrary $ pd
+    exe   = f2 . map snd . condExecutables $ pd
+    tests = f3 . map snd . condTestSuites  $ pd
+    bench = f4 . map snd . condBenchmarks  $ pd
+
+----------------------------------------------------------------
+
+includeDirectories :: String -> String -> [FilePath] -> [String]
+includeDirectories cdir wdir []   = uniqueAndSort [cdir,wdir]
+includeDirectories cdir wdir dirs = uniqueAndSort (map (cdir </>) dirs ++ [cdir,wdir])
+
+----------------------------------------------------------------
+
+uniqueAndSort :: [String] -> [String]
+uniqueAndSort = toList . fromList
+
+----------------------------------------------------------------
+
+getGHCVersion :: IO (String, Int)
+getGHCVersion = ghcVer >>= toTupple
+  where
+    ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)
+    toTupple Nothing  = throwIO $ userError "ghc not found"
+    toTupple (Just v)
+      | length vs < 2 = return (verstr, 0)
+      | otherwise     = return (verstr, ver)
+      where
+        vs = versionBranch v
+        ver = (vs !! 0) * 100 + (vs !! 1)
+        verstr = intercalate "." . map show $ vs