diff --git a/.gitignore b/.gitignore index 0c36049..61ecc03 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ dist/ elisp/*.elc *~ /.cabal-sandbox/ +add-source-timestamps package.cache cabal.sandbox.config # Mac OS generates diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 50b6759..8264a35 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -12,6 +12,10 @@ module Language.Haskell.GhcMod.CabalApi ( , cabalConfigDependencies ) where +#if MIN_VERSION_base(4,7,0) +import Prelude hiding (catch) +#endif + import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Utils diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index d63e806..9a6e732 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -12,19 +12,25 @@ module Language.Haskell.GhcMod.GhcPkg ( , getPackageDbStack ) where -import Config (cProjectVersionInt) -- ghc version -import Control.Applicative ((<$>)) +import Config (cProjectVersionInt,cProjectVersion,cTargetPlatformString) +import DynFlags (DynFlags(..), systemPackageConfig,getDynFlags) +import Exception (handleIO) +import CoreMonad (liftIO) +import Control.Applicative ((<$>),(<*>),(*>)) import Control.Exception (SomeException(..)) +import Control.Monad (void) import qualified Control.Exception as E import Data.Char (isSpace,isAlphaNum) import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) -import Data.Maybe (listToMaybe, maybeToList) +import Data.Maybe (catMaybes) import Distribution.Package (InstalledPackageId(..)) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import {-# SOURCE #-} Language.Haskell.GhcMod.Monad import System.FilePath (()) -import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof) +import System.Directory (getAppUserDataDirectory,doesDirectoryExist) +import Text.ParserCombinators.ReadP (ReadP, char, satisfy, between, sepBy1, many1, manyTill, skipMany, skipSpaces, string, choice) import qualified Text.ParserCombinators.ReadP as P ghcVersion :: Int @@ -59,31 +65,42 @@ getPackageDbStack cdir = (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] + + +-- Copied from ghc module `Packages' unfortunately it's not exported :/ +resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath) +resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df) +resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_os ++ '-':target_arch ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where + [target_arch,_,target_os] = splitOn "-" cTargetPlatformString +resolvePackageDb _ (PackageDb name) = return $ Just name + + -- | List packages in one or more ghc package store -ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName] +ghcPkgList :: [GhcPkgDb] -> GhcMod [PackageBaseName] ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs where fst3 (x,_,_) = x -ghcPkgListEx :: [GhcPkgDb] -> IO [Package] +ghcPkgListEx :: [GhcPkgDb] -> GhcMod [Package] ghcPkgListEx dbs = do - parseGhcPkgOutput .lines <$> readProcess' "ghc-pkg" opts - where + df <- getDynFlags + out <- liftIO $ readProcess' "ghc-pkg" opts + rdbs <- catMaybes <$> mapM (liftIO . resolvePackageDb df) dbs + return $ concatMap snd $ filter ((`elem` rdbs) . fst) $ parseGhcPkgOutput out + where opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs -parseGhcPkgOutput :: [String] -> [Package] -parseGhcPkgOutput [] = [] -parseGhcPkgOutput (l:ls) = - parseGhcPkgOutput ls ++ case l of - [] -> [] - h:_ | isSpace h -> maybeToList $ packageLine l - | otherwise -> [] - -packageLine :: String -> Maybe Package -packageLine l = - case listToMaybe $ P.readP_to_S packageLineP l of - Just ((Normal,p),_) -> Just p - Just ((Hidden,p),_) -> Just p - _ -> Nothing +parseGhcPkgOutput :: String -> [(FilePath, [Package])] +parseGhcPkgOutput p = + case P.readP_to_S ghcPkgOutputP p of + (a, rest):_ | all isSpace rest -> a + res@(a,reset):_ -> error $ "parseGhcPkgOutput: " ++ show a ++ "\nwith rest:```" ++ reset ++ "```\n\nwhole result: " ++ show res + _ -> error $ "parseGhcPkgOutput: failed to parse output!\n\n" ++ p fromInstalledPackageId' :: InstalledPackageId -> Maybe Package fromInstalledPackageId' pid = let @@ -99,21 +116,42 @@ fromInstalledPackageId pid = Nothing -> error $ "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" +ghcPkgOutputP :: ReadP [(FilePath, [Package])] +ghcPkgOutputP = do + dbs <- ghcPkgOutputP' + return $ do + (path, ps) <- dbs + return (path,map snd $ filter ((`elem`[Normal,Hidden]) . fst) ps) + +ghcPkgOutputP' :: ReadP [(FilePath, [(PackageState, Package)])] +ghcPkgOutputP' = do + skipUseCacheLinesP *> (many1 $ (,) <$> pathLineP <*> many1 packageLineP) + where + skipUseCacheLinesP = skipMany $ do + void $ string "using cache:" + void $ manyTill (satisfy $ const True) (char '\n') + +pathLineP :: ReadP FilePath +pathLineP = do + p <- (:) <$> char '/' <*> manyTill (satisfy $ const True) (char ':') + void $ char '\n' + return p + data PackageState = Normal | Hidden | Broken deriving (Eq,Show) packageLineP :: ReadP (PackageState, Package) packageLineP = do - P.skipSpaces + skipSpaces p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP , (Broken,) <$> between (char '{') (char '}') packageP , (Normal,) <$> packageP ] - eof + void $ char '\n' return p packageP :: ReadP (PackageBaseName, PackageVersion, PackageId) packageP = do pkgSpec@(name,ver) <- packageSpecP - P.skipSpaces + skipSpaces i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec return (name,ver,i) @@ -125,11 +163,11 @@ packageSpecP = do packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId packageIdSpecP (name,ver) = do string name >> char '-' >> string ver >> char '-' >> return () - many1 (P.satisfy isAlphaNum) + many1 (satisfy isAlphaNum) packageCompCharP :: ReadP Char packageCompCharP = - P.satisfy $ \c -> isAlphaNum c || c `elem` "_-." + satisfy $ \c -> isAlphaNum c || c `elem` "_-." -- | Get options needed to add a list of package dbs to ghc-pkg's db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs new file mode 100644 index 0000000..ee7e5b6 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies #-} +module Language.Haskell.GhcMod.Monad ( + GhcMod + , GhcModEnv(..) + , GhcModWriter + , GhcModState(..) + , runGhcMod' + , runGhcMod + , toGhcMod + , module Control.Monad.Reader.Class + , module Control.Monad.Writer.Class + , module Control.Monad.State.Class + ) where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Cradle +import Language.Haskell.GhcMod.GHCApi + +import GHC +import GHC.Paths (libdir) +import GhcMonad +import Exception +import MonadUtils +import DynFlags + +import Data.IORef (IORef, readIORef, writeIORef, newIORef) + +import Control.Monad (liftM) +import Control.Monad.Base (MonadBase,liftBase) +--import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.RWS.Lazy (RWST,runRWST) +import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith + , control, liftBaseOp, liftBaseOp_) +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.State.Class + +data GhcModEnv = GhcModEnv { + gmGhcSession :: !(IORef HscEnv) + , gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModState = GhcModState + +defaultState :: GhcModState +defaultState = GhcModState + +type GhcModWriter = () + +newtype GhcMod a = GhcMod { + unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a } + deriving (Functor, + Applicative, + Monad, + MonadIO, + MonadReader GhcModEnv, + MonadWriter GhcModWriter, + MonadState GhcModState) + +runGhcMod' :: GhcModEnv + -> GhcModState + -> GhcMod a + -> IO (a,(GhcModState, GhcModWriter)) +runGhcMod' r s a = do + (a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s + return (a',(s',w)) + +runGhcMod :: Options -> GhcMod a -> IO a +runGhcMod opt a = do + session <- newIORef (error "empty session") + cradle <- findCradle + let env = GhcModEnv { gmGhcSession = session + , gmOptions = opt + , gmCradle = cradle } + fst <$> runGhcMod' env defaultState (a' cradle) + where + a' cradle = (toGhcMod $ initializeFlagsWithCradle opt cradle) >> a + +toGhcMod :: Ghc a -> GhcMod a +toGhcMod a = do + s <- gmGhcSession <$> ask + liftIO $ unGhc a $ Session s + +instance MonadBase IO GhcMod where + liftBase = GhcMod . liftBase + +instance MonadBaseControl IO GhcMod where + newtype StM GhcMod a = StGhcMod { + unStGhcMod :: StM (RWST GhcModEnv () GhcModState IO) a } + + liftBaseWith f = GhcMod . liftBaseWith $ \runInBase -> + f $ liftM StGhcMod . runInBase . unGhcMod + + restoreM = GhcMod . restoreM . unStGhcMod + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance GhcMonad GhcMod where + getSession = liftIO . readIORef . gmGhcSession =<< ask + setSession a = liftIO . flip writeIORef a . gmGhcSession =<< ask + +instance HasDynFlags GhcMod where + getDynFlags = getSessionDynFlags + +instance ExceptionMonad GhcMod where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/Monad.hs-boot b/Language/Haskell/GhcMod/Monad.hs-boot new file mode 100644 index 0000000..5f80fc3 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE RoleAnnotations #-} +module Language.Haskell.GhcMod.Monad where + +import DynFlags (HasDynFlags) +import Control.Monad.IO.Class (MonadIO) +import Control.Applicative (Applicative) + +data GhcMod a +type role GhcMod nominal + +instance Functor GhcMod +instance Applicative GhcMod +instance Monad GhcMod + +instance HasDynFlags GhcMod +instance MonadIO GhcMod diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 7141c4b..464353f 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -52,6 +52,7 @@ Library GHC-Options: -Wall Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Ghc + Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Internal Other-Modules: Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse @@ -80,6 +81,7 @@ Library , directory , filepath , ghc + , ghc-paths , ghc-syb-utils , hlint >= 1.8.61 , io-choice @@ -88,6 +90,9 @@ Library , syb , time , transformers + , transformers-base + , mtl + , monad-control , split if impl(ghc < 7.7) Build-Depends: convertible @@ -151,6 +156,7 @@ Test-Suite spec , directory , filepath , ghc + , ghc-paths , ghc-syb-utils , hlint >= 1.7.1 , io-choice @@ -159,6 +165,9 @@ Test-Suite spec , syb , time , transformers + , transformers-base + , mtl + , monad-control , hspec >= 1.8.2 , split if impl(ghc < 7.7) diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 00e78ab..46b6b8e 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -37,8 +37,8 @@ spec = do , includeDirs = map (toRelativeDir dir) (includeDirs res) } if ghcVersion < 706 - then ghcOptions res' `shouldBe` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - else ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98","-optP-include","-optP" ++ cwd "test/data/dist/build/autogen/cabal_macros.h"] + then ghcOptions res' `shouldContain` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] + else ghcOptions res' `shouldContain` ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"] (pkgName `map` depPackages res') `shouldContain` ["Cabal"] diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs index 6e80a03..07f6dea 100644 --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -2,6 +2,9 @@ module GhcPkgSpec where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Monad + +import CoreMonad (liftIO) import Control.Applicative import System.Directory @@ -22,7 +25,8 @@ spec = do getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException describe "getPackageDbPackages" $ do - it "find a config file and extracts packages" $ do - sdb <- getSandboxDb "test/data/check-packageid" + it "find a config file and extracts packages" $ + runGhcMod defaultOptions $ do + sdb <- liftIO $ getSandboxDb "test/data/check-packageid" pkgs <- ghcPkgListEx [PackageDb sdb] - pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")] + liftIO $ pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]