packageinfo done

2 files changed, 77 insertions, 74 deletions

diff --git a/haskell-code-explorer.cabal b/haskell-code-explorer.cabal
index 06cb5c8..a0dddda 100644
--- a/haskell-code-explorer.cabal
+++ b/haskell-code-explorer.cabal
@@ -34,6 +34,7 @@ library
                , containers
                , directory
                , directory-tree
+               , exceptions
                , filemanip
                , filepath
                , ghc
diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs
index 466b518..0800382 100644
--- a/src/HaskellCodeExplorer/PackageInfo.hs
+++ b/src/HaskellCodeExplorer/PackageInfo.hs
@@ -12,7 +12,7 @@ module HaskellCodeExplorer.PackageInfo
   ( createPackageInfo
   , ghcVersion
   ) where
-
+import qualified Data.List.NonEmpty as NE
 import Control.DeepSeq(deepseq)
 import Control.Exception
   ( IOException
@@ -22,6 +22,7 @@ import Control.Exception
   , throw
   , try
   )
+import qualified Data.Map as Map
 import Control.Monad (foldM, unless, when)
 import Control.Monad.Extra (anyM, findM)
 import Control.Monad.Logger
@@ -42,37 +43,39 @@ import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import Data.Version (Version(..), showVersion, makeVersion)
-import Digraph (flattenSCCs)
+import GHC.Data.Graph.Directed (flattenSCCs)
 import Distribution.Helper
   ( ChComponentName(..)
   , ChEntrypoint(..)
   , ChModuleName(..)
-  , components
-  , entrypoints
-  , ghcOptions
+  , ProjLoc(..)
+  , DistDir(..)
+  , SCabalProjType(..)
+  , allUnits
+  , UnitInfo(..)
+  , ChComponentInfo(..)
   , mkQueryEnv
-  , packageId
   , runQuery
-  , sourceDirs
-  , compilerVersion
   )
-import DynFlags
-  ( DynFlags(..)
-  , GeneralFlag(..)
-  , GhcMode(..)
-  , WarnReason(..)
-  , gopt_set
+import GHC.Driver.Session
+  ( gopt_set
   , parseDynamicFlagsCmdLine
   )
-import Exception (ExceptionMonad(..), ghandle)
+import Control.Monad.Catch
+  ( handle
+  )
+import GHC.Utils.Exception
+  ( ExceptionMonad
+  )
 import GHC
   ( GhcLink(..)
-  , HscTarget(..)
+  , Backend(..)
+  , GhcMode(..)
+  , DynFlags(..)
+  , GeneralFlag(..)
   , LoadHowMuch(..)
   , ModLocation(..)
   , ModSummary(..)
-  , Severity
-  , SrcSpan
   , getModuleGraph
   , getSession
   , getSessionDynFlags
@@ -89,13 +92,15 @@ import GHC
   , moduleName
   )
 import GHC.Paths (libdir)
-import GhcMonad (GhcT(..), liftIO)
+import GHC.Driver.Monad (GhcT(..), liftIO)
 import HaskellCodeExplorer.GhcUtils (isHsBoot,toText)
-import HaskellCodeExplorer.ModuleInfo (ModuleDependencies, createModuleInfo)
+import HaskellCodeExplorer.ModuleInfo
+  ( ModuleDependencies
+  , createModuleInfo
+  )
 import qualified HaskellCodeExplorer.Types as HCE
-import HscTypes (hsc_EPS, hsc_HPT)
-import Outputable (PprStyle, SDoc, neverQualify, showSDocForUser)
-import Packages (initPackages)
+import GHC.Driver.Env (hsc_EPS, hsc_HPT, hsc_units)
+import GHC.Unit.Module.Graph (filterToposortToModules)
 import Prelude hiding (id)
 import System.Directory
   ( doesFileExist
@@ -162,15 +167,25 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
                  , T.pack packageDirectoryAbsPath
                  ]
              liftIO exitFailure
-  let cabalHelperQueryEnv = mkQueryEnv packageDirectoryAbsPath distDir
+  cabalHelperQueryEnv <- liftIO $
+                         mkQueryEnv
+                         (ProjLocV2Dir packageDirectoryAbsPath)
+                         (DistDirCabal SCV2 distDir)
   ((packageName, packageVersion), (_packageCompilerName, packageCompilerVersion), compInfo) <-
-    liftIO $
+    liftIO $ NE.head <$>
     runQuery
+      (allUnits
+       (\unit ->
+          (uiPackageId unit, uiCompilerId unit,
+           map (\comp -> ((ciGhcOptions comp, ciComponentName comp),
+                          (ciEntrypoints comp, ciComponentName comp),
+                          (ciSourceDirs comp, ciComponentName comp))) $
+            (Map.elems . uiComponents) unit)))
       cabalHelperQueryEnv
-      ((,,) <$> packageId <*> compilerVersion <*>
-       (zip3 <$> components ((,) <$> ghcOptions) <*>
-        components ((,) <$> entrypoints) <*>
-        components ((,) <$> sourceDirs)))
+      -- ((,,) <$> packageId <*> compilerVersion <*>
+      --  (zip3 <$> components ((,) <$> ghcOptions) <*>
+      --   components ((,) <$> entrypoints) <*>
+      --   components ((,) <$> sourceDirs)))
   let currentPackageId = HCE.PackageId (T.pack packageName) packageVersion
   unless
     (take 3 (versionBranch packageCompilerVersion) ==
@@ -258,22 +273,22 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
         L.map chModuleToString otherModules ++ L.map chModuleToString signatures)
     chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) =
       (Just mainModule, [])
-    chEntrypointsToModules ChSetupEntrypoint = (Nothing, [])
+    chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, [])
     chModuleToString :: ChModuleName -> String
     chModuleToString (ChModuleName n) = n
     chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType
     chComponentNameToComponentType ChSetupHsName = HCE.Setup
-    chComponentNameToComponentType ChLibName = HCE.Lib
-    chComponentNameToComponentType (ChSubLibName name) =
-      HCE.SubLib $ T.pack name
+    chComponentNameToComponentType (ChLibName _) = HCE.Lib
+    -- chComponentNameToComponentType (ChSubLibName name) =
+    --   HCE.SubLib $ T.pack name
     chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name
     chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name
     chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name
     chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name
     chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId
-    chComponentNameToComponentId ChLibName = HCE.ComponentId "lib"
-    chComponentNameToComponentId (ChSubLibName name) =
-      HCE.ComponentId . T.append "sublib-" . T.pack $ name
+    chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib"
+    -- chComponentNameToComponentId (ChSubLibName name) =
+    --   HCE.ComponentId . T.append "sublib-" . T.pack $ name
     chComponentNameToComponentId (ChFLibName name) =
       HCE.ComponentId . T.append "flib-" . T.pack $ name
     chComponentNameToComponentId (ChExeName name) =
@@ -445,15 +460,17 @@ eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f =
     accumulator
     idOccMap
 
-instance ExceptionMonad (LoggingT IO) where
-  gcatch act h =
-    LoggingT $ \logFn ->
-      runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn
-  gmask f =
-    LoggingT $ \logFn ->
-      gmask $ \io_restore ->
-        let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf)
-         in runLoggingT (f g_restore) logFn
+-- loggingT IO is already MonadCatch and MonadMask
+-- instance MonadCatch (LoggingT IO) where
+--   catch act h =
+--     LoggingT $ \logFn ->
+--       runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn
+-- instance MonadMask (LoggingT IO) where
+--   mask f =
+--     LoggingT $ \logFn ->
+--       gmask $ \io_restore ->
+--         let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf)
+--          in runLoggingT (f g_restore) logFn
 
 instance MonadLoggerIO (GhcT (LoggingT IO)) where
   askLoggerIO = GhcT $ const askLoggerIO
@@ -467,7 +484,7 @@ gtrySync action = ghandleSync (return . Left) (fmap Right action)
 
 ghandleSync :: (ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
 ghandleSync onError =
-  ghandle
+  handle
     (\ex ->
        case fromException ex of
          Just (asyncEx :: SomeAsyncException) -> throw asyncEx
@@ -505,49 +522,33 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
         parseDynamicFlagsCmdLine
           flags
           (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal
-      (flags'', _) <- liftIO $ initPackages flags'
-      logFn <- askLoggerIO
-      let logAction ::
-               DynFlags
-            -> WarnReason
-            -> Severity
-            -> SrcSpan
-            -> Outputable.PprStyle
-            -> SDoc
-            -> IO ()
-          logAction fs _reason _severity srcSpan _stype msg =
-            runLoggingT
-              (logDebugN
-                 (T.append "GHC message : " $
-                  T.pack $
-                  showSDocForUser fs neverQualify msg ++
-                  " , SrcSpan : " ++ show srcSpan))
-              logFn
-          mbTmpDir =
-            case hiDir flags'' of
+      let mbTmpDir =
+            case hiDir flags' of
               Just buildDir ->
                 Just $ buildDir </> (takeBaseName buildDir ++ "-tmp")
               Nothing -> Nothing
       _ <-
+        -- initUnits happens here
         setSessionDynFlags $
         L.foldl'
           gopt_set
-          (flags''
-             { hscTarget = HscAsm
+          (flags'
+             { backend = NCG
              , ghcLink = LinkInMemory
              , ghcMode = CompManager
-             , log_action = logAction
-             , importPaths = importPaths flags'' ++ maybeToList mbTmpDir
+             , importPaths = importPaths flags' ++ maybeToList mbTmpDir
              })
           [Opt_Haddock]
       targets <- mapM (`guessTarget` Nothing) modules
       setTargets targets
       _ <- load LoadAllTargets
       modGraph <- getModuleGraph
-      let topSortMods = flattenSCCs (topSortModuleGraph False modGraph Nothing)
+      let topSortMods =
+            flattenSCCs $
+            filterToposortToModules (topSortModuleGraph False modGraph Nothing)
           buildDir =
             addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $
-            flags''
+            flags'
           pathsModuleName =
             "Paths_" ++
             map
@@ -583,7 +584,7 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
         logErrorN $
         T.append
           "Cannot find module path : "
-          (toText flags'' $ map ms_mod modulesNotFound)
+          (toText flags' $ map ms_mod modulesNotFound)
       foldM
         (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> do
            result <-
@@ -591,7 +592,7 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
                sourceCodePreprocessing
                componentId
                currentPackageId
-               flags''
+               flags'
                (fileMap', defSiteMap', modNameMap')
                (modulePath, modSum)
            case result of
@@ -673,6 +674,7 @@ indexModule sourceCodePreprocessing componentId currentPackageId flags deps (mod
           createModuleInfo
             deps
             ( flags
+            , hsc_units hscEnv
             , typecheckedModule
             , hsc_HPT hscEnv
             , externalPackageState