From bc71877dcfbd43a1434ebc9840e4a176e29982ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 4 Mar 2015 16:45:26 +0100 Subject: [PATCH] Change the way cabal-helper is built a bit --- CabalHelper/Common.hs | 96 ++++++++++++ {cabal-helper => CabalHelper}/Main.hs | 55 +++---- CabalHelper/Types.hs | 18 +++ {cabal-helper => CabalHelper}/Wrapper.hs | 192 ++++++++++++++--------- Language/Haskell/GhcMod/CabalHelper.hs | 7 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 1 - Language/Haskell/GhcMod/Types.hs | 66 ++++++-- cabal-helper/Common.hs | 41 ----- ghc-mod.cabal | 11 +- 9 files changed, 314 insertions(+), 173 deletions(-) create mode 100644 CabalHelper/Common.hs rename {cabal-helper => CabalHelper}/Main.hs (89%) create mode 100644 CabalHelper/Types.hs rename {cabal-helper => CabalHelper}/Wrapper.hs (55%) delete mode 100644 cabal-helper/Common.hs diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs new file mode 100644 index 0000000..692b373 --- /dev/null +++ b/CabalHelper/Common.hs @@ -0,0 +1,96 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module CabalHelper.Common where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.List +import Data.Maybe +import Data.Version +import Data.Typeable +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import System.Environment +import System.IO +import System.Exit +import Text.ParserCombinators.ReadP + +data Panic = Panic String deriving (Typeable, Show) +instance Exception Panic + +panic :: String -> a +panic msg = throw $ Panic msg + +handlePanic :: IO a -> IO a +handlePanic action = + action `catch` \(Panic msg) -> errMsg msg >> exitFailure + +errMsg :: String -> IO () +errMsg str = do + prog <- getProgName + hPutStrLn stderr $ prog ++ ": " ++ str + +align :: String -> String -> String -> String +align n an str = let + h:rest = lines str + [hm] = match n h + rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] + in + unlines (h:rest') + where + match p str' = maybeToList $ + fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') + move i str' | i > 0 = replicate i ' ' ++ str' + move i str' = drop i str' + + +-- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and +-- compiler version +getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version)) +getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do + parseHeader <$> BS.hGetLine h + +parseHeader :: ByteString -> Maybe (Version, Version) +parseHeader header = case BS8.words header of + ["Saved", "package", "config", "for", _pkgId , + "written", "by", cabalId, + "using", compId] + -> liftM2 (,) (ver cabalId) (ver compId) + _ -> Nothing + where + ver i = snd <$> parsePkgId i + +parsePkgId :: ByteString -> Maybe (ByteString, Version) +parsePkgId bs = + case BS8.split '-' bs of + [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) + _ -> Nothing + +parseVer :: String -> Version +parseVer vers = runReadP parseVersion vers + +-- majorVer :: Version -> Version +-- majorVer (Version b _) = Version (take 2 b) [] + +-- sameMajorVersion :: Version -> Version -> Bool +-- sameMajorVersion a b = majorVer a == majorVer b + +runReadP :: ReadP t -> String -> t +runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a diff --git a/cabal-helper/Main.hs b/CabalHelper/Main.hs similarity index 89% rename from cabal-helper/Main.hs rename to CabalHelper/Main.hs index a405d1e..b5ca210 100644 --- a/cabal-helper/Main.hs +++ b/CabalHelper/Main.hs @@ -33,6 +33,8 @@ import Distribution.PackageDescription (PackageDescription, import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.Simple.Program (requireProgram, ghcProgram) +import Distribution.Simple.Program.Types (ConfiguredProgram(..)) import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), Component(..), @@ -70,26 +72,9 @@ import System.Exit import System.IO import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) import Text.Printf -import Common ---- \ / These types MUST be in sync with the copies in lib:ghc-mod -data GmComponentName = GmSetupHsName - | GmLibName - | GmExeName String - | GmTestName String - | GmBenchName String - deriving (Eq, Ord, Read, Show) -data GmCabalHelperResponse - = GmCabalHelperStrings [(GmComponentName, [String])] - | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] - | GmCabalHelperLbi String - deriving (Read, Show) ---- ^ These types MUST be in sync with the copies in ../Types.hs - - --- MUST be compatible to the one in GHC -newtype ModuleName = ModuleName String - deriving (Eq, Ord, Read, Show) +import CabalHelper.Common +import CabalHelper.Types usage = do prog <- getProgName @@ -177,7 +162,7 @@ main = do [] -> removeInplaceDeps pd clbi opts = componentGhcOptions v lbi bi clbi' outdir in - renderGhcOptions (compiler lbi) $ opts `mappend` adopts + renderGhcOptions' lbi v $ opts `mappend` adopts "ghc-src-options":flags -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ @@ -200,7 +185,7 @@ main = do ghcOptSourcePath = ghcOptSourcePath opts } in - renderGhcOptions comp $ opts `mappend` adopts + renderGhcOptions' lbi v $ opts `mappend` adopts "ghc-pkg-options":flags -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ @@ -218,19 +203,19 @@ main = do ghcOptHideAllPackages = ghcOptHideAllPackages opts } in - renderGhcOptions (compiler lbi) $ opts' `mappend` adopts + renderGhcOptions' lbi v $ opts' `mappend` adopts "entrypoints":[] -> do eps <- componentsMap lbi v distdir $ \c clbi bi -> - componentEntrypoints c + return $ componentEntrypoints c -- MUST append Setup component at the end otherwise CabalHelper gets -- confused - let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])] + let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])] return $ Just $ GmCabalHelperEntrypoints eps' "source-dirs":[] -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> hsSourceDirs bi + \c clbi bi -> return $ hsSourceDirs bi "print-lbi":[] -> return $ Just $ GmCabalHelperLbi $ show lbi @@ -253,7 +238,7 @@ componentsMap :: LocalBuildInfo -> ( Component -> ComponentLocalBuildInfo -> BuildInfo - -> a) + -> IO a) -> IO [(GmComponentName, a)] componentsMap lbi v distdir f = do let pd = localPkgDescr lbi @@ -265,7 +250,8 @@ componentsMap lbi v distdir f = do name = componentNameFromComponent c l' <- readIORef lr - writeIORef lr $ (componentNameToGm name, f c clbi bi):l' + r <- f c clbi bi + writeIORef lr $ (componentNameToGm name, r):l' reverse <$> readIORef lr componentNameToGm CLibName = GmLibName @@ -287,10 +273,10 @@ componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})= exeOutDir lbi benchmarkName -gmModuleName :: C.ModuleName -> ModuleName -gmModuleName = ModuleName . intercalate "." . components +gmModuleName :: C.ModuleName -> GmModuleName +gmModuleName = GmModuleName . intercalate "." . components -componentEntrypoints :: Component -> Either FilePath [ModuleName] +componentEntrypoints :: Component -> Either FilePath [GmModuleName] componentEntrypoints (CLib Library {..}) = Right $ map gmModuleName exposedModules componentEntrypoints (CExe Executable {..}) @@ -343,3 +329,12 @@ removeInplaceDeps pd clbi = let where isInplaceDep :: (InstalledPackageId, PackageId) -> Bool isInplaceDep (ipid, pid) = inplacePackageId pid == ipid + +renderGhcOptions' lbi v opts = do +#if CABAL_MAJOR == 1 && CABAL_MINOR < 20 + (ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi) + let Just ghcVer = programVersion ghcProg + return $ renderGhcOptions ghcVer opts +#else + return $ renderGhcOptions (compiler lbi) opts +#endif diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs new file mode 100644 index 0000000..273df7d --- /dev/null +++ b/CabalHelper/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module CabalHelper.Types where + +newtype GmModuleName = GmModuleName String + deriving (Read, Show) + +data GmComponentName = GmSetupHsName + | GmLibName + | GmExeName String + | GmTestName String + | GmBenchName String + deriving (Eq, Ord, Read, Show) + +data GmCabalHelperResponse + = GmCabalHelperStrings [(GmComponentName, [String])] + | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [GmModuleName])] + | GmCabalHelperLbi String + deriving (Read, Show) diff --git a/cabal-helper/Wrapper.hs b/CabalHelper/Wrapper.hs similarity index 55% rename from cabal-helper/Wrapper.hs rename to CabalHelper/Wrapper.hs index 40c6315..9c460ab 100644 --- a/cabal-helper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards #-} module Main where import Control.Applicative @@ -26,11 +26,7 @@ import Data.List import Data.Maybe import Data.String import Data.Version -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 import Text.Printf -import Text.ParserCombinators.ReadP import System.Environment import System.Directory import System.FilePath @@ -44,7 +40,7 @@ import Distribution.Text (display) import NotCPP.Declarations import Paths_ghc_mod -import Common +import CabalHelper.Common import Utils ifD [d| getExecutablePath = getProgName |] @@ -61,21 +57,21 @@ usage = do \)\n" main :: IO () -main = do +main = handlePanic $ do args <- getArgs case args of "print-appdatadir":[] -> putStrLn =<< appDataDir "print-build-platform":[] -> putStrLn $ display buildPlatform distdir:_ -> do cfgf <- canonicalizePath (distdir "setup-config") - mhdr <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf + mhdr <- getCabalConfigHeader cfgf case mhdr of - Nothing -> error $ printf "\ + Nothing -> panic $ printf "\ \Could not read Cabal's persistent setup configuration header\n\ \- Check first line of: %s\n\ \- Maybe try: $ cabal configure" cfgf - Just Header {..} -> do + Just (hdrCabalVersion, _hdrCompilerVersion) -> do eexe <- compileHelper hdrCabalVersion case eexe of Left e -> exitWith e @@ -92,17 +88,17 @@ tryFindSrcDirInGhcModTree :: IO (Maybe FilePath) tryFindSrcDirInGhcModTree = do dir <- (!!4) . iterate takeDirectory <$> getExecutablePath exists <- doesFileExist $ dir "ghc-mod.cabal" - src_exists <- doesFileExist $ dir "cabal-helper/Main.hs" + src_exists <- doesFileExist $ dir "CabalHelper/Main.hs" if exists && src_exists - then return $ Just (dir "cabal-helper") + then return $ Just dir else return Nothing tryFindRealSrcDir :: IO (Maybe FilePath) tryFindRealSrcDir = do datadir <- getDataDir - exists <- doesFileExist $ datadir "cabal-helper/Main.hs" + exists <- doesFileExist $ datadir "CabalHelper/Main.hs" return $ if exists - then Just $ datadir "cabal-helper" + then Just datadir else Nothing findCabalHelperSourceDir :: IO FilePath @@ -116,35 +112,52 @@ findCabalHelperSourceDir = do compileHelper :: Version -> IO (Either ExitCode FilePath) compileHelper cabalVer = do chdir <- findCabalHelperSourceDir - mver <- find (sameMajorVersion cabalVer) <$> listCabalVersions - couldBeSrcDir <- takeDirectory <$> getDataDir - case mver of - Nothing -> do - let cabalFile = couldBeSrcDir "Cabal.cabal" - cabal <- doesFileExist cabalFile - if cabal - then do - ver <- cabalFileVersion <$> readFile cabalFile - compile $ Compile chdir (Just couldBeSrcDir) ver [] - else errorNoCabal cabalVer - Just ver -> - compile $ Compile chdir Nothing ver [cabalPkgId ver] + -- First check if we already compiled this version of cabal + db_exists <- cabalPkgDbExists cabalVer + case db_exists of + True -> compileWithPkg chdir . Just =<< cabalPkgDb cabalVer + False -> do + -- Next check if this version is globally available + mver <- find (== cabalVer) <$> listCabalVersions + couldBeSrcDir <- takeDirectory <$> getDataDir + case mver of + Nothing -> do + -- If not see if we're in a cabal source tree + let cabalFile = couldBeSrcDir "Cabal.cabal" + cabal <- doesFileExist cabalFile + if cabal + then do + ver <- cabalFileVersion <$> readFile cabalFile + compileWithCabalTree chdir ver couldBeSrcDir + else do + -- otherwise compile the requested cabal version into an isolated + -- package-db + db <- installCabal cabalVer + compileWithPkg chdir (Just db) + Just _ -> + compileWithPkg chdir Nothing + where + compileWithCabalTree chdir ver srcDir = + compile $ Compile chdir (Just srcDir) Nothing ver [] + + compileWithPkg chdir mdb = + compile $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] + cabalPkgId v = "Cabal-" ++ showVersion v -errorNoCabal :: Version -> a -errorNoCabal cabalVer = error $ printf "\ -\No appropriate Cabal package found, wanted version %s.\n\ -\- Check output of: $ ghc-pkg list Cabal\n\ -\- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s.*'" sver mjver - where - sver = showVersion cabalVer - mjver = showVersion $ majorVer cabalVer +-- errorNoCabal :: Version -> a +-- errorNoCabal cabalVer = panic $ printf "\ +-- \No appropriate Cabal package found, wanted version %s.\n\ +-- \- Check output of: $ ghc-pkg list Cabal\n\ +-- \- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s'" sver sver +-- where +-- sver = showVersion cabalVer errorNoMain :: FilePath -> a -errorNoMain datadir = error $ printf "\ -\Could not find $datadir/cabal-helper/Main.hs!\n\ +errorNoMain datadir = panic $ printf "\ +\Could not find $datadir/CabalHelper/Main.hs!\n\ \\n\ \If you are a developer you can use the environment variable `ghc_mod_datadir'\n\ \to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\ @@ -158,6 +171,7 @@ errorNoMain datadir = error $ printf "\ data Compile = Compile { cabalHelperSourceDir :: FilePath, cabalSourceDir :: Maybe FilePath, + packageDb :: Maybe FilePath, cabalVersion :: Version, packageDeps :: [String] } @@ -167,7 +181,7 @@ compile Compile {..} = do outdir <- appDataDir createDirectoryIfMissing True outdir - let exe = outdir "cabal-helper-" ++ showVersion (majorVer cabalVersion) + let exe = outdir "cabal-helper-" ++ showVersion cabalVersion recompile <- case cabalSourceDir of @@ -182,24 +196,43 @@ compile Compile {..} = do concat [ [ "-outputdir", outdir , "-o", exe + , "-optP-DCABAL_HELPER=1" , "-optP-DCABAL_MAJOR=" ++ show mj , "-optP-DCABAL_MINOR=" ++ show mi ], + maybeToList $ ("-package-db="++) <$> packageDb, map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir, concatMap (\p -> ["-package", p]) packageDeps, - [ "--make", cabalHelperSourceDir "Main.hs" ] + [ "--make", cabalHelperSourceDir "CabalHelper/Main.hs" ] ] if recompile then do - (_, _, _, h) <- createProcess - (proc "ghc" ghc_opts) { std_out = UseHandle stderr } - rv <- waitForProcess h + rv <- callProcessStderr' Nothing "ghc" ghc_opts return $ case rv of ExitSuccess -> Right exe e@(ExitFailure _) -> Left e else return $ Right exe +callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode +callProcessStderr' mwd exe args = do + (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr + , cwd = mwd } + waitForProcess h + +callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO () +callProcessStderr mwd exe args = do + rv <- callProcessStderr' mwd exe args + case rv of + ExitSuccess -> return () + ExitFailure v -> processFailedException "callProcessStderr" exe args v + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + panic $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] + timeHsFiles :: FilePath -> IO [TimedFile] timeHsFiles dir = do fs <- map (dir) <$> getDirectoryContents dir @@ -209,17 +242,50 @@ timeHsFiles dir = do exists <- doesFileExist f return $ exists && ".hs" `isSuffixOf` f +installCabal :: Version -> IO FilePath +installCabal ver = do + db <- createPkgDb ver + callProcessStderr (Just "/") "cabal" [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ db + , "-j1" + , "install", "Cabal-"++showVersion ver + ] + return db +createPkgDb :: Version -> IO FilePath +createPkgDb ver = do + db <- cabalPkgDb ver + exists <- doesDirectoryExist db + when (not exists) $ callProcessStderr Nothing "ghc-pkg" ["init", db] + return db + +cabalPkgDb :: Version -> IO FilePath +cabalPkgDb ver = do + appdir <- appDataDir + return $ appdir "cabal-" ++ showVersion ver ++ "-db" + +cabalPkgDbExists :: Version -> IO Bool +cabalPkgDbExists ver = do + db <- cabalPkgDb ver + dexists <- doesDirectoryExist db + case dexists of + False -> return False + True -> do + vers <- listCabalVersions' (Just db) + return $ ver `elem` vers + +listCabalVersions :: IO [Version] +listCabalVersions = listCabalVersions' Nothing -- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions :: IO [Version] -listCabalVersions = do - catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] "" +listCabalVersions' :: Maybe FilePath -> IO [Version] +listCabalVersions' mdb = do + let mdbopt = ("--package-db="++) <$> mdb + opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt -data Header = Header { hdrCabalVersion :: Version - , hdrCompilerVersion :: Version - } + catMaybes . map (fmap snd . parsePkgId . fromString) . words + <$> readProcess "ghc-pkg" opts "" -- | Find @version: XXX@ delcaration in a cabal file cabalFileVersion :: String -> Version @@ -228,31 +294,3 @@ cabalFileVersion cabalFile = do where ls = map (map toLower) $ lines cabalFile extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace) - -parseHeader :: ByteString -> Maybe Header -parseHeader header = case BS8.words header of - ["Saved", "package", "config", "for", _pkgId , - "written", "by", cabalId, - "using", compId] - -> liftM2 Header (ver cabalId) (ver compId) - _ -> error "parsing setup-config header failed" - where - ver i = snd <$> parsePkgId i - -parsePkgId :: ByteString -> Maybe (ByteString, Version) -parsePkgId bs = - case BS8.split '-' bs of - [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) - _ -> Nothing - -parseVer :: String -> Version -parseVer vers = runReadP parseVersion vers - -majorVer :: Version -> Version -majorVer (Version b _) = Version (take 2 b) [] - -sameMajorVersion :: Version -> Version -> Bool -sameMajorVersion a b = majorVer a == majorVer b - -runReadP :: ReadP t -> String -> t -runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 1542f94..c98bd63 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.CabalHelper ( ) where import Control.Applicative +import Control.Arrow import Control.Monad import Data.Monoid import Data.List @@ -100,5 +101,9 @@ cabalHelper = withCabal $ do Just (GmCabalHelperStrings ghcOpts), Just (GmCabalHelperStrings ghcSrcOpts), Just (GmCabalHelperStrings ghcPkgOpts) ] = res + eps' = map (second $ fmap $ map md) eps - return $ CabalHelper eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts + return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts + + where + md (GmModuleName mn) = mkModuleName mn diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 818a955..8eb91c2 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -24,7 +24,6 @@ import Data.List import Data.Char import Data.Maybe import Data.Traversable (traverse) -import Types import System.Directory import System.FilePath import System.IO.Unsafe diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index db71b60..ceed2d7 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types - , module Types + , module CabalHelper.Types , ModuleName , mkModuleName , moduleNameString @@ -11,6 +11,7 @@ module Language.Haskell.GhcMod.Types ( import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) import Control.Exception (Exception) +import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -22,7 +23,7 @@ import MonadUtils (MonadIO) import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) -import Types +import CabalHelper.Types -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. @@ -95,6 +96,52 @@ data Cradle = Cradle { ---------------------------------------------------------------- +-- | GHC package database flags. +data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) + +-- | A single GHC command line option. +type GHCOption = String + +-- | An include directory for modules. +type IncludeDir = FilePath + +-- | A package name. +type PackageBaseName = String + +-- | A package version. +type PackageVersion = String + +-- | A package id. +type PackageId = String + +-- | A package's name, verson and id. +type Package = (PackageBaseName, PackageVersion, PackageId) + +pkgName :: Package -> PackageBaseName +pkgName (n,_,_) = n + +pkgVer :: Package -> PackageVersion +pkgVer (_,v,_) = v + +pkgId :: Package -> PackageId +pkgId (_,_,i) = i + +showPkg :: Package -> String +showPkg (n,v,_) = intercalate "-" [n,v] + +showPkgId :: Package -> String +showPkgId (n,v,i) = intercalate "-" [n,v,i] + +-- | Haskell expression. +type Expression = String + +-- | Module name. +type ModuleString = String + +-- | A Module +type Module = [String] + + data GmLogLevel = GmPanic | GmException | GmError @@ -140,21 +187,6 @@ instance Read ModuleName where (m,t) <- readsPrec (app_prec+1) s]) r where app_prec = 10 - ---- \ / These types MUST be in sync with the copies in cabal-helper/Main.hs -data GmComponentName = GmSetupHsName - | GmLibName - | GmExeName String - | GmTestName String - | GmBenchName String - deriving (Eq, Ord, Read, Show) -data GmCabalHelperResponse - = GmCabalHelperStrings [(GmComponentName, [String])] - | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] - | GmCabalHelperLbi String - deriving (Read, Show) ---- ^ These types MUST be in sync with the copies in cabal-helper/Main.hs - data GhcModError = GMENoMsg -- ^ Unknown error diff --git a/cabal-helper/Common.hs b/cabal-helper/Common.hs deleted file mode 100644 index ed58f81..0000000 --- a/cabal-helper/Common.hs +++ /dev/null @@ -1,41 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -module Common where - -import Control.Applicative -import Data.List -import Data.Maybe -import System.Environment -import System.IO - -errMsg :: String -> IO () -errMsg str = do - prog <- getProgName - hPutStrLn stderr $ prog ++ ": " ++ str - -align :: String -> String -> String -> String -align n an str = let - h:rest = lines str - [hm] = match n h - rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] - in - unlines (h:rest') - where - match p str' = maybeToList $ - fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') - move i str' | i > 0 = replicate i ' ' ++ str' - move i str' = drop i str' diff --git a/ghc-mod.cabal b/ghc-mod.cabal index b6dfa20..be85601 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -23,7 +23,7 @@ Cabal-Version: >= 1.16 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el - cabal-helper/*.hs + CabalHelper/*.hs Extra-Source-Files: ChangeLog SetupCompat.hs @@ -65,8 +65,8 @@ Library Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod - Types Utils + CabalHelper.Types Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CaseSplit @@ -177,10 +177,10 @@ Executable ghc-modi Executable cabal-helper-wrapper Default-Language: Haskell2010 Other-Extensions: TemplateHaskell - Main-Is: Wrapper.hs + Main-Is: CabalHelper/Wrapper.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall - HS-Source-Dirs: cabal-helper, . + HS-Source-Dirs: . X-Install-Target: $libexecdir Build-Depends: base >= 4.0 && < 5 , bytestring @@ -207,14 +207,13 @@ Test-Suite doctest Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, - ConstraintKinds, FlexibleContexts, OverloadedStrings + ConstraintKinds, FlexibleContexts Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall -fno-warn-deprecations CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod - Types Dir Spec TestUtils