hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'DanielG-dev-monad'

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-05-08 10:40:56 +09:00
commit ec5e42a5ba
8 changed files with 215 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -2,6 +2,7 @@ dist/
elisp/*.elc
*~
/.cabal-sandbox/
add-source-timestamps
package.cache
cabal.sandbox.config
# Mac OS generates

4
Language/Haskell/GhcMod/CabalApi.hs
View File

@ -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

90
Language/Haskell/GhcMod/GhcPkg.hs
View File

@ -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
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

111
Language/Haskell/GhcMod/Monad.hs Normal file
View File

@ -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

16
Language/Haskell/GhcMod/Monad.hs-boot Normal file
View File

@ -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

9
ghc-mod.cabal
View File

@ -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)

4
test/CabalApiSpec.hs
View File

@ -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"]

10
test/GhcPkgSpec.hs
View File

@ -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")]