Merge branch 'DanielG-dev-monad'

.gitignore

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

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

Language/Haskell/GhcMod/GhcPkg.hs

@@ -12,19 +12,25 @@ module Language.Haskell.GhcMod.GhcPkg (
   , getPackageDbStack
   ) 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.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
-  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
 
-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' 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

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

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

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)

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"]
+                  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"]
                 (pkgName `map` depPackages res') `shouldContain` ["Cabal"]
 

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
+        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 `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]
+            liftIO $ pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]