Merge branch 'dev-monad' of git://github.com/DanielG/ghc-mod into DanielG-dev-monad

This commit is contained in:
Kazu Yamamoto 2014-05-08 10:39:06 +09:00
commit 410a7e00a2
8 changed files with 215 additions and 32 deletions

1
.gitignore vendored
View File

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

View File

@ -12,6 +12,10 @@ module Language.Haskell.GhcMod.CabalApi (
, cabalConfigDependencies , cabalConfigDependencies
) where ) where
#if MIN_VERSION_base(4,7,0)
import Prelude hiding (catch)
#endif
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils

View File

@ -12,19 +12,25 @@ module Language.Haskell.GhcMod.GhcPkg (
, getPackageDbStack , getPackageDbStack
) where ) where
import Config (cProjectVersionInt) -- ghc version import Config (cProjectVersionInt,cProjectVersion,cTargetPlatformString)
import Control.Applicative ((<$>)) import DynFlags (DynFlags(..), systemPackageConfig,getDynFlags)
import Exception (handleIO)
import CoreMonad (liftIO)
import Control.Applicative ((<$>),(<*>),(*>))
import Control.Exception (SomeException(..)) import Control.Exception (SomeException(..))
import Control.Monad (void)
import qualified Control.Exception as E import qualified Control.Exception as E
import Data.Char (isSpace,isAlphaNum) import Data.Char (isSpace,isAlphaNum)
import Data.List (isPrefixOf, intercalate) import Data.List (isPrefixOf, intercalate)
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import Data.Maybe (listToMaybe, maybeToList) import Data.Maybe (catMaybes)
import Distribution.Package (InstalledPackageId(..)) import Distribution.Package (InstalledPackageId(..))
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import {-# SOURCE #-} Language.Haskell.GhcMod.Monad
import System.FilePath ((</>)) 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 import qualified Text.ParserCombinators.ReadP as P
ghcVersion :: Int ghcVersion :: Int
@ -59,31 +65,42 @@ getPackageDbStack cdir =
(getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
`E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] `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 -- | List packages in one or more ghc package store
ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName] ghcPkgList :: [GhcPkgDb] -> GhcMod [PackageBaseName]
ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs
where fst3 (x,_,_) = x where fst3 (x,_,_) = x
ghcPkgListEx :: [GhcPkgDb] -> IO [Package] ghcPkgListEx :: [GhcPkgDb] -> GhcMod [Package]
ghcPkgListEx dbs = do ghcPkgListEx dbs = do
parseGhcPkgOutput .lines <$> readProcess' "ghc-pkg" opts df <- getDynFlags
where 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 opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs
parseGhcPkgOutput :: [String] -> [Package] parseGhcPkgOutput :: String -> [(FilePath, [Package])]
parseGhcPkgOutput [] = [] parseGhcPkgOutput p =
parseGhcPkgOutput (l:ls) = case P.readP_to_S ghcPkgOutputP p of
parseGhcPkgOutput ls ++ case l of (a, rest):_ | all isSpace rest -> a
[] -> [] res@(a,reset):_ -> error $ "parseGhcPkgOutput: " ++ show a ++ "\nwith rest:```" ++ reset ++ "```\n\nwhole result: " ++ show res
h:_ | isSpace h -> maybeToList $ packageLine l _ -> error $ "parseGhcPkgOutput: failed to parse output!\n\n" ++ p
| 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
fromInstalledPackageId' :: InstalledPackageId -> Maybe Package fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
fromInstalledPackageId' pid = let fromInstalledPackageId' pid = let
@ -99,21 +116,42 @@ fromInstalledPackageId pid =
Nothing -> error $ Nothing -> error $
"fromInstalledPackageId: `"++show pid++"' is not a valid package-id" "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) data PackageState = Normal | Hidden | Broken deriving (Eq,Show)
packageLineP :: ReadP (PackageState, Package) packageLineP :: ReadP (PackageState, Package)
packageLineP = do packageLineP = do
P.skipSpaces skipSpaces
p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP
, (Broken,) <$> between (char '{') (char '}') packageP , (Broken,) <$> between (char '{') (char '}') packageP
, (Normal,) <$> packageP ] , (Normal,) <$> packageP ]
eof void $ char '\n'
return p return p
packageP :: ReadP (PackageBaseName, PackageVersion, PackageId) packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)
packageP = do packageP = do
pkgSpec@(name,ver) <- packageSpecP pkgSpec@(name,ver) <- packageSpecP
P.skipSpaces skipSpaces
i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec
return (name,ver,i) return (name,ver,i)
@ -125,11 +163,11 @@ packageSpecP = do
packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId
packageIdSpecP (name,ver) = do packageIdSpecP (name,ver) = do
string name >> char '-' >> string ver >> char '-' >> return () string name >> char '-' >> string ver >> char '-' >> return ()
many1 (P.satisfy isAlphaNum) many1 (satisfy isAlphaNum)
packageCompCharP :: ReadP Char packageCompCharP :: ReadP Char
packageCompCharP = 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 -- | Get options needed to add a list of package dbs to ghc-pkg's db stack
ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack

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

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

View File

@ -52,6 +52,7 @@ Library
GHC-Options: -Wall GHC-Options: -Wall
Exposed-Modules: Language.Haskell.GhcMod Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Ghc Language.Haskell.GhcMod.Ghc
Language.Haskell.GhcMod.Monad
Language.Haskell.GhcMod.Internal Language.Haskell.GhcMod.Internal
Other-Modules: Language.Haskell.GhcMod.Boot Other-Modules: Language.Haskell.GhcMod.Boot
Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.Browse
@ -80,6 +81,7 @@ Library
, directory , directory
, filepath , filepath
, ghc , ghc
, ghc-paths
, ghc-syb-utils , ghc-syb-utils
, hlint >= 1.8.61 , hlint >= 1.8.61
, io-choice , io-choice
@ -88,6 +90,9 @@ Library
, syb , syb
, time , time
, transformers , transformers
, transformers-base
, mtl
, monad-control
, split , split
if impl(ghc < 7.7) if impl(ghc < 7.7)
Build-Depends: convertible Build-Depends: convertible
@ -151,6 +156,7 @@ Test-Suite spec
, directory , directory
, filepath , filepath
, ghc , ghc
, ghc-paths
, ghc-syb-utils , ghc-syb-utils
, hlint >= 1.7.1 , hlint >= 1.7.1
, io-choice , io-choice
@ -159,6 +165,9 @@ Test-Suite spec
, syb , syb
, time , time
, transformers , transformers
, transformers-base
, mtl
, monad-control
, hspec >= 1.8.2 , hspec >= 1.8.2
, split , split
if impl(ghc < 7.7) if impl(ghc < 7.7)

View File

@ -37,8 +37,8 @@ spec = do
, includeDirs = map (toRelativeDir dir) (includeDirs res) , includeDirs = map (toRelativeDir dir) (includeDirs res)
} }
if ghcVersion < 706 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"] 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' `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"] 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"] 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"] (pkgName `map` depPackages res') `shouldContain` ["Cabal"]

View File

@ -2,6 +2,9 @@ module GhcPkgSpec where
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
import CoreMonad (liftIO)
import Control.Applicative import Control.Applicative
import System.Directory import System.Directory
@ -22,7 +25,8 @@ spec = do
getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException
describe "getPackageDbPackages" $ do describe "getPackageDbPackages" $ do
it "find a config file and extracts packages" $ do it "find a config file and extracts packages" $
sdb <- getSandboxDb "test/data/check-packageid" runGhcMod defaultOptions $ do
sdb <- liftIO $ getSandboxDb "test/data/check-packageid"
pkgs <- ghcPkgListEx [PackageDb sdb] pkgs <- ghcPkgListEx [PackageDb sdb]
pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")] liftIO $ pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]