{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PartialTypeSignatures      #-}
{-# LANGUAGE ViewPatterns               #-}

module Language.Haskell.Liquid.GHC.Interface (

  -- * Determine the build-order for target files
   realTargets

  , getInterfaceDynFlags

  -- * Extract all information needed for verification
  , getTargetInfos
  , runLiquidGhc

  -- * Printer
  , pprintCBs

  -- * predicates
  -- , isExportedVar
  -- , exportedVars

  -- * Internal exports (provisional)
  , extractSpecComments
  , extractSpecQuotes'
  , makeLogicMap
  , classCons
  , derivedVars
  , importVars
  , makeGhcSrc
  , allImports
  , qualifiedImports
  , modSummaryHsFile
  , makeFamInstEnv
  , findAndParseSpecFiles
  , parseSpecFile
  , noTerm
  , clearSpec
  , checkFilePragmas
  , keepRawTokenStream
  , ignoreInline
  , lookupTyThings
  , availableTyCons
  , availableVars
  , updLiftedSpec
  , loadDependenciesOf
  ) where

import Prelude hiding (error)

import qualified Outputable as O
import GHC hiding (Target, Located, desugarModule)
import qualified GHC
import GHC.Paths (libdir)
import GHC.Serialized

import qualified Language.Haskell.Liquid.GHC.API as Ghc
import Annotations
import Avail
import Class
import CoreMonad
import CoreSyn
import DataCon
import Digraph
import DriverPhases
import DriverPipeline
import DynFlags
import Finder
import HscTypes hiding (Target)
import IdInfo
import InstEnv
import Module
import Panic (throwGhcExceptionIO)
-- import Serialized
import TcRnTypes
import Var
-- import NameSet
import FastString
import FamInstEnv
import FamInst
import qualified TysPrim
import GHC.LanguageExtensions

import Control.Exception
import Control.Monad

import Data.Bifunctor
import Data.Data
import Data.List hiding (intersperse)
import Data.Maybe

import Data.Generics.Aliases (mkT)
import Data.Generics.Schemes (everywhere)

import qualified Data.HashSet        as S
import qualified Data.Map            as M
import qualified Data.HashMap.Strict as HM

import System.Console.CmdArgs.Verbosity hiding (Loud)
import System.Directory
import System.FilePath
import System.IO.Temp
import Text.Parsec.Pos
import Text.PrettyPrint.HughesPJ        hiding (first, (<>))
import Language.Fixpoint.Types          hiding (panic, Error, Result, Expr)
import qualified Language.Fixpoint.Misc as Misc
import Language.Haskell.Liquid.Bare
import Language.Haskell.Liquid.GHC.Misc
import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..), miModGuts)
import Language.Haskell.Liquid.GHC.Play
import qualified Language.Haskell.Liquid.GHC.GhcMonadLike as GhcMonadLike
import Language.Haskell.Liquid.GHC.GhcMonadLike (GhcMonadLike, askHscEnv)
import Language.Haskell.Liquid.WiredIn (isDerivedInstance) 
import qualified Language.Haskell.Liquid.Measure  as Ms
import qualified Language.Haskell.Liquid.Misc     as Misc
import Language.Haskell.Liquid.Parse
import Language.Haskell.Liquid.Transforms.ANF
import Language.Haskell.Liquid.Types hiding (Spec)
-- import Language.Haskell.Liquid.Types.PrettyPrint
-- import Language.Haskell.Liquid.Types.Visitors
import Language.Haskell.Liquid.UX.CmdLine
import Language.Haskell.Liquid.UX.QuasiQuoter
import Language.Haskell.Liquid.UX.Tidy
import Language.Fixpoint.Utils.Files

import Optics

import qualified Debug.Trace as Debug 


--------------------------------------------------------------------------------
{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to 
     return a list of files

       [i1, i2, ... ] ++ [f1, f2, ...]

     1. Where each file only (transitively imports) PRECEDIING ones; 
     2. `f1..` are a permutation of the original `targets`;
     3. `i1..` either don't have "fresh" .bspec files. 

 -}
--------------------------------------------------------------------------------
realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] 
realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]
realTargets  Maybe HscEnv
mbEnv Config
cfg [FilePath]
tgtFs 
  | Config -> Bool
noCheckImports Config
cfg = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
tgtFs
  | Bool
otherwise          = do 
    FilePath
incDir   <- IO FilePath
Misc.getIncludeDir 
    [FilePath]
allFs    <- Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]
orderTargets Maybe HscEnv
mbEnv Config
cfg [FilePath]
tgtFs
    let srcFs :: [FilePath]
srcFs = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
Misc.isIncludeFile FilePath
incDir) [FilePath]
allFs
    [FilePath]
realFs   <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
check [FilePath]
srcFs
    FilePath
dir      <- IO FilePath
getCurrentDirectory
    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return      (FilePath -> FilePath -> FilePath
makeRelative FilePath
dir (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
realFs)
  where 
    check :: FilePath -> IO Bool
check FilePath
f    = Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet FilePath -> FilePath -> IO Bool
skipTarget HashSet FilePath
tgts FilePath
f 
    tgts :: HashSet FilePath
tgts       = [FilePath] -> HashSet FilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [FilePath]
tgtFs

getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags
getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags
getInterfaceDynFlags Maybe HscEnv
mbEnv Config
cfg = Maybe HscEnv -> Config -> Ghc DynFlags -> IO DynFlags
forall a. Maybe HscEnv -> Config -> Ghc a -> IO a
runLiquidGhc Maybe HscEnv
mbEnv Config
cfg (Ghc DynFlags -> IO DynFlags) -> Ghc DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags

orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] 
orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]
orderTargets Maybe HscEnv
mbEnv Config
cfg [FilePath]
tgtFiles = Maybe HscEnv -> Config -> Ghc [FilePath] -> IO [FilePath]
forall a. Maybe HscEnv -> Config -> Ghc a -> IO a
runLiquidGhc Maybe HscEnv
mbEnv Config
cfg (Ghc [FilePath] -> IO [FilePath])
-> Ghc [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do 
  ModuleGraph
homeModules <- [FilePath] -> Ghc ModuleGraph
configureGhcTargets [FilePath]
tgtFiles
  [FilePath] -> Ghc [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return         (ModSummary -> FilePath
modSummaryHsFile (ModSummary -> FilePath) -> [ModSummary] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
homeModules)


skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool
skipTarget :: HashSet FilePath -> FilePath -> IO Bool
skipTarget HashSet FilePath
tgts FilePath
f 
  | FilePath -> HashSet FilePath -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member FilePath
f HashSet FilePath
tgts = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False          -- Always check target file 
  | Bool
otherwise       = FilePath -> IO Bool
hasFreshBinSpec FilePath
f     -- But skip an import with fresh .bspec

hasFreshBinSpec :: FilePath -> IO Bool
hasFreshBinSpec :: FilePath -> IO Bool
hasFreshBinSpec FilePath
srcF = do 
  let specF :: FilePath
specF = Ext -> FilePath -> FilePath
extFileName Ext
BinSpec FilePath
srcF
  Maybe UTCTime
srcMb    <- FilePath -> IO (Maybe UTCTime)
Misc.lastModified FilePath
srcF 
  Maybe UTCTime
specMb   <- FilePath -> IO (Maybe UTCTime)
Misc.lastModified FilePath
specF 
  case (Maybe UTCTime
srcMb, Maybe UTCTime
specMb) of 
    (Just UTCTime
srcT, Just UTCTime
specT) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
srcT UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
specT)
    (Maybe UTCTime, Maybe UTCTime)
_                       -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False



--------------------------------------------------------------------------------
-- | GHC Interface Pipeline ----------------------------------------------------
--------------------------------------------------------------------------------

getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)
getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)
getTargetInfos Maybe HscEnv
hscEnv Config
cfg [FilePath]
tgtFiles' = do
  [FilePath]
tgtFiles <- (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
canonicalizePath [FilePath]
tgtFiles'
  [()]
_        <- (FilePath -> IO ()) -> [FilePath] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO ()
checkFilePresent [FilePath]
tgtFiles
  ()
_        <- (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
createTempDirectoryIfMissing [FilePath]
tgtFiles
  LogicMap
logicMap <- IO LogicMap -> IO LogicMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LogicMap
makeLogicMap
  Maybe HscEnv
-> Config
-> Ghc ([TargetInfo], HscEnv)
-> IO ([TargetInfo], HscEnv)
forall a. Maybe HscEnv -> Config -> Ghc a -> IO a
runLiquidGhc Maybe HscEnv
hscEnv Config
cfg (Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)
getTargetInfos' Config
cfg LogicMap
logicMap [FilePath]
tgtFiles)

checkFilePresent :: FilePath -> IO ()
checkFilePresent :: FilePath -> IO ()
checkFilePresent FilePath
f = do
  Bool
b <- FilePath -> IO Bool
doesFileExist FilePath
f
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SrcSpan -> FilePath -> IO ()
forall a. Maybe SrcSpan -> FilePath -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (FilePath
"Cannot find file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f)

getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)
getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)
getTargetInfos' Config
cfg LogicMap
logicMap [FilePath]
tgtFiles = do
  ()
_           <- Config -> Ghc ()
compileCFiles Config
cfg
  ModuleGraph
homeModules <- [FilePath] -> Ghc ModuleGraph
configureGhcTargets [FilePath]
tgtFiles
  DepGraph
depGraph    <- ModuleGraph -> Ghc DepGraph
buildDepGraph ModuleGraph
homeModules
  [TargetInfo]
ghcInfos    <- Config
-> LogicMap
-> [FilePath]
-> DepGraph
-> ModuleGraph
-> Ghc [TargetInfo]
processModules Config
cfg LogicMap
logicMap [FilePath]
tgtFiles DepGraph
depGraph ModuleGraph
homeModules
  HscEnv
hscEnv      <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  ([TargetInfo], HscEnv) -> Ghc ([TargetInfo], HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TargetInfo]
ghcInfos, HscEnv
hscEnv)

createTempDirectoryIfMissing :: FilePath -> IO ()
createTempDirectoryIfMissing :: FilePath -> IO ()
createTempDirectoryIfMissing FilePath
tgtFile = FilePath -> IO () -> IO ()
Misc.tryIgnore FilePath
"create temp directory" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
tempDirectory FilePath
tgtFile

--------------------------------------------------------------------------------
-- | GHC Configuration & Setup -------------------------------------------------
--------------------------------------------------------------------------------
runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a
runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a
runLiquidGhc Maybe HscEnv
hscEnv Config
cfg Ghc a
act =
  FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"liquid" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
tmp ->
    Maybe FilePath -> Ghc a -> IO a
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      Ghc () -> (HscEnv -> Ghc ()) -> Maybe HscEnv -> Ghc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession Maybe HscEnv
hscEnv
      DynFlags
df <- Config -> FilePath -> Ghc DynFlags
configureDynFlags Config
cfg FilePath
tmp
      DynFlags -> Ghc a -> Ghc a
forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
df Ghc a
act

updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs 
updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs
updateIncludePaths DynFlags
df [FilePath]
ps = IncludeSpecs -> [FilePath] -> IncludeSpecs
addGlobalInclude (DynFlags -> IncludeSpecs
includePaths DynFlags
df) [FilePath]
ps 

configureDynFlags :: Config -> FilePath -> Ghc DynFlags
configureDynFlags :: Config -> FilePath -> Ghc DynFlags
configureDynFlags Config
cfg FilePath
tmp = do
  DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  (DynFlags
df',[Located FilePath]
_,[Warn]
_) <- DynFlags
-> [Located FilePath] -> Ghc (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlags DynFlags
df ([Located FilePath] -> Ghc (DynFlags, [Located FilePath], [Warn]))
-> [Located FilePath] -> Ghc (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ (FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Located FilePath
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ([FilePath] -> [Located FilePath])
-> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
ghcOptions Config
cfg
  Bool
loud <- IO Bool -> Ghc Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
isLoud
  let df'' :: DynFlags
df'' = DynFlags
df' { importPaths :: [FilePath]
importPaths  = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
idirs Config
cfg [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
importPaths DynFlags
df'
                 , libraryPaths :: [FilePath]
libraryPaths = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
idirs Config
cfg [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
libraryPaths DynFlags
df'
                 , includePaths :: IncludeSpecs
includePaths = DynFlags -> [FilePath] -> IncludeSpecs
updateIncludePaths DynFlags
df' (Config -> [FilePath]
idirs Config
cfg) -- addGlobalInclude (includePaths df') (idirs cfg) 
                 , packageFlags :: [PackageFlag]
packageFlags = FilePath -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage FilePath
""
                                                (FilePath -> PackageArg
PackageArg FilePath
"ghc-prim")
                                                (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True [])
                                PackageFlag -> [PackageFlag] -> [PackageFlag]
forall a. a -> [a] -> [a]
: (DynFlags -> [PackageFlag]
packageFlags DynFlags
df')

                 , debugLevel :: Int
debugLevel   = Int
1               -- insert SourceNotes
                 -- , profAuto     = ProfAutoCalls
                 , ghcLink :: GhcLink
ghcLink      = GhcLink
LinkInMemory
                 , hscTarget :: HscTarget
hscTarget    = HscTarget
HscInterpreted
                 , ghcMode :: GhcMode
ghcMode      = GhcMode
CompManager
                 -- prevent GHC from printing anything, unless in Loud mode
                 , log_action :: LogAction
log_action   = if Bool
loud
                                    then LogAction
defaultLogAction
                                    else \DynFlags
_ WarnReason
_ Severity
_ SrcSpan
_ PprStyle
_ MsgDoc
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 -- redirect .hi/.o/etc files to temp directory
                 , objectDir :: Maybe FilePath
objectDir    = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
tmp
                 , hiDir :: Maybe FilePath
hiDir        = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
tmp
                 , stubDir :: Maybe FilePath
stubDir      = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
tmp
                 } DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
                   DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_PIC
                   DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypedHoles
                   DynFlags -> Extension -> DynFlags
`xopt_set` Extension
MagicHash
                   DynFlags -> Extension -> DynFlags
`xopt_set` Extension
DeriveGeneric
                   DynFlags -> Extension -> DynFlags
`xopt_set` Extension
StandaloneDeriving
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df''
  DynFlags -> Ghc DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
df''

configureGhcTargets :: [FilePath] -> Ghc ModuleGraph
configureGhcTargets :: [FilePath] -> Ghc ModuleGraph
configureGhcTargets [FilePath]
tgtFiles = do
  [Target]
targets         <- (FilePath -> Ghc Target) -> [FilePath] -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
`guessTarget` Maybe Phase
forall a. Maybe a
Nothing) [FilePath]
tgtFiles
  ()
_               <- [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
targets
  ModuleGraph
moduleGraph     <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False -- see [NOTE:DROP-BOOT-FILES]

  let homeModules :: [ModSummary]
homeModules  = (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
isBootSummary) ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$
                     [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
moduleGraph Maybe ModuleName
forall a. Maybe a
Nothing
  let homeNames :: [ModuleName]
homeNames    = Module -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModSummary]
homeModules
  ()
_               <- [ModuleName] -> Ghc ()
setTargetModules [ModuleName]
homeNames
  IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath, [ModuleName]) -> IO ()
forall a. Show a => a -> IO ()
print    (FilePath
"Module Dependencies", [ModuleName]
homeNames)
  ModuleGraph -> Ghc ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleGraph -> Ghc ModuleGraph) -> ModuleGraph -> Ghc ModuleGraph
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
homeModules

setTargetModules :: [ModuleName] -> Ghc ()
setTargetModules :: [ModuleName] -> Ghc ()
setTargetModules [ModuleName]
modNames = [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets ([Target] -> Ghc ()) -> [Target] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
mkTarget (ModuleName -> Target) -> [ModuleName] -> [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
modNames
  where
    mkTarget :: ModuleName -> Target
mkTarget ModuleName
modName = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
TargetModule ModuleName
modName) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing

compileCFiles :: Config -> Ghc ()
compileCFiles :: Config -> Ghc ()
compileCFiles Config
cfg = do
  DynFlags
df  <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  [InstalledUnitId]
_   <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (DynFlags -> Ghc [InstalledUnitId])
-> DynFlags -> Ghc [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$
           DynFlags
df { includePaths :: IncludeSpecs
includePaths = DynFlags -> [FilePath] -> IncludeSpecs
updateIncludePaths DynFlags
df (Config -> [FilePath]
idirs Config
cfg) 
              , importPaths :: [FilePath]
importPaths  = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
idirs Config
cfg [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
importPaths DynFlags
df
              , libraryPaths :: [FilePath]
libraryPaths = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
idirs Config
cfg [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
libraryPaths DynFlags
df }
  HscEnv
hsc <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  [FilePath]
os  <- (FilePath -> Ghc FilePath) -> [FilePath] -> Ghc [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
x -> IO FilePath -> Ghc FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Ghc FilePath) -> IO FilePath -> Ghc FilePath
forall a b. (a -> b) -> a -> b
$ HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile HscEnv
hsc Phase
StopLn (FilePath
x,Maybe Phase
forall a. Maybe a
Nothing)) ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
cFiles Config
cfg)
  DynFlags
df  <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  Ghc [InstalledUnitId] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [InstalledUnitId] -> Ghc ())
-> Ghc [InstalledUnitId] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (DynFlags -> Ghc [InstalledUnitId])
-> DynFlags -> Ghc [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ DynFlags
df { ldInputs :: [Option]
ldInputs = [Option] -> [Option]
forall a. Eq a => [a] -> [a]
nub ([Option] -> [Option]) -> [Option] -> [Option]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
FileOption FilePath
"") [FilePath]
os [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
df }

{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.
      We do it manually rather than using the flag to topSortModuleGraph
      because otherwise the order of mutually recursive modules depends
      on the modulename, e.g. given

      Bar.hs --> Foo.hs --> Bar.hs-boot

      we'll get
      
      [Bar.hs, Foo.hs]
    
      which is backwards..
 -}
--------------------------------------------------------------------------------
-- Home Module Dependency Graph ------------------------------------------------
--------------------------------------------------------------------------------

type DepGraph = Graph DepGraphNode
type DepGraphNode = Node Module ()

reachableModules :: DepGraph -> Module -> [Module]
reachableModules :: DepGraph -> Module -> [Module]
reachableModules DepGraph
depGraph Module
mod =
  Node Module () -> Module
forall key payload. Node key payload -> key
node_key (Node Module () -> Module) -> [Node Module ()] -> [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node Module ()] -> [Node Module ()]
forall a. [a] -> [a]
tail (DepGraph -> Node Module () -> [Node Module ()]
forall node. Graph node -> node -> [node]
reachableG DepGraph
depGraph (() -> Module -> [Module] -> Node Module ()
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode () Module
mod []))

buildDepGraph :: ModuleGraph -> Ghc DepGraph
buildDepGraph :: ModuleGraph -> Ghc DepGraph
buildDepGraph ModuleGraph
homeModules =
  [Node Module ()] -> DepGraph
forall key payload.
Ord key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesOrd ([Node Module ()] -> DepGraph)
-> Ghc [Node Module ()] -> Ghc DepGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModSummary -> Ghc (Node Module ()))
-> [ModSummary] -> Ghc [Node Module ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModSummary -> Ghc (Node Module ())
mkDepGraphNode (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
homeModules)

mkDepGraphNode :: ModSummary -> Ghc DepGraphNode
mkDepGraphNode :: ModSummary -> Ghc (Node Module ())
mkDepGraphNode ModSummary
modSummary = 
  () -> Module -> [Module] -> Node Module ()
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode () (ModSummary -> Module
ms_mod ModSummary
modSummary) ([Module] -> Node Module ())
-> Ghc [Module] -> Ghc (Node Module ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module -> Ghc Bool) -> [Module] -> Ghc [Module]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Module -> Ghc Bool
forall (m :: * -> *). GhcMonadLike m => Module -> m Bool
isHomeModule ([Module] -> Ghc [Module]) -> Ghc [Module] -> Ghc [Module]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> Ghc [Module]
forall (m :: * -> *). GhcMonadLike m => ModSummary -> m [Module]
modSummaryImports ModSummary
modSummary)

isHomeModule :: GhcMonadLike m => Module -> m Bool
isHomeModule :: Module -> m Bool
isHomeModule Module
mod = do
  UnitId
homePkg <- DynFlags -> UnitId
thisPackage (DynFlags -> UnitId) -> m DynFlags -> m UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return   (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
homePkg

modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module]
modSummaryImports :: ModSummary -> m [Module]
modSummaryImports ModSummary
modSummary =
  ((Maybe FastString, Located ModuleName) -> m Module)
-> [(Maybe FastString, Located ModuleName)] -> m [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module -> (Maybe FastString, Located ModuleName) -> m Module
forall (m :: * -> *).
GhcMonadLike m =>
Module -> (Maybe FastString, Located ModuleName) -> m Module
importDeclModule (ModSummary -> Module
ms_mod ModSummary
modSummary))
       (ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps ModSummary
modSummary)

importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString,  GHC.Located ModuleName) -> m Module
importDeclModule :: Module -> (Maybe FastString, Located ModuleName) -> m Module
importDeclModule Module
fromMod (Maybe FastString
pkgQual, Located ModuleName
locModName) = do
  HscEnv
hscEnv <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let modName :: SrcSpanLess (Located ModuleName)
modName = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
locModName
  FindResult
result <- IO FindResult -> m FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> m FindResult) -> IO FindResult -> m FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hscEnv ModuleName
modName Maybe FastString
pkgQual
  case FindResult
result of
    Finder.Found ModLocation
_ Module
mod -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
mod
    FindResult
_ -> do
      DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ GhcException -> IO Module
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO Module) -> GhcException -> IO Module
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$
        DynFlags -> ModuleName -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
O.showPpr DynFlags
dflags (Module -> ModuleName
moduleName Module
fromMod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        DynFlags -> MsgDoc -> FilePath
O.showSDoc DynFlags
dflags (DynFlags -> ModuleName -> FindResult -> MsgDoc
cannotFindModule DynFlags
dflags ModuleName
modName FindResult
result)

--------------------------------------------------------------------------------
-- | Extract Ids ---------------------------------------------------------------
--------------------------------------------------------------------------------

classCons :: Maybe [ClsInst] -> [Id]
classCons :: Maybe [ClsInst] -> [Id]
classCons Maybe [ClsInst]
Nothing   = []
classCons (Just [ClsInst]
cs) = (ClsInst -> [Id]) -> [ClsInst] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataCon -> [Id]
dataConImplicitIds (DataCon -> [Id]) -> (ClsInst -> DataCon) -> ClsInst -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataCon] -> DataCon
forall a. [a] -> a
head ([DataCon] -> DataCon)
-> (ClsInst -> [DataCon]) -> ClsInst -> DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons (TyCon -> [DataCon]) -> (ClsInst -> TyCon) -> ClsInst -> [DataCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> TyCon
classTyCon (Class -> TyCon) -> (ClsInst -> Class) -> ClsInst -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Class
is_cls) [ClsInst]
cs

derivedVars :: Config -> MGIModGuts -> [Var]  
derivedVars :: Config -> MGIModGuts -> [Id]
derivedVars Config
cfg MGIModGuts
mg  = (ClsInst -> [Id]) -> [ClsInst] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CoreProgram -> Id -> [Id]
dFunIdVars CoreProgram
cbs (Id -> [Id]) -> (ClsInst -> Id) -> ClsInst -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Id
is_dfun) [ClsInst]
derInsts 
  where 
    derInsts :: [ClsInst]
derInsts        
      | Bool
checkDer    = [ClsInst]
insts 
      | Bool
otherwise   = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter ClsInst -> Bool
isDerivedInstance [ClsInst]
insts
    insts :: [ClsInst]
insts           = MGIModGuts -> [ClsInst]
mgClsInstances MGIModGuts
mg 
    checkDer :: Bool
checkDer        = Config -> Bool
checkDerived Config
cfg
    cbs :: CoreProgram
cbs             = MGIModGuts -> CoreProgram
mgi_binds MGIModGuts
mg
               

mgClsInstances :: MGIModGuts -> [ClsInst]
mgClsInstances :: MGIModGuts -> [ClsInst]
mgClsInstances = [ClsInst] -> Maybe [ClsInst] -> [ClsInst]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [ClsInst] -> [ClsInst])
-> (MGIModGuts -> Maybe [ClsInst]) -> MGIModGuts -> [ClsInst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst 

dFunIdVars :: CoreProgram -> DFunId -> [Id]
dFunIdVars :: CoreProgram -> Id -> [Id]
dFunIdVars CoreProgram
cbs Id
fd  = FilePath -> [Id] -> [Id]
forall a. PPrint a => FilePath -> a -> a
notracepp FilePath
msg ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ (Bind Id -> [Id]) -> CoreProgram -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
bindersOf CoreProgram
cbs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
deps
  where
    msg :: FilePath
msg            = FilePath
"DERIVED-VARS-OF: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Id -> FilePath
forall a. PPrint a => a -> FilePath
showpp Id
fd
    cbs' :: CoreProgram
cbs'           = (Bind Id -> Bool) -> CoreProgram -> CoreProgram
forall a. (a -> Bool) -> [a] -> [a]
filter Bind Id -> Bool
f CoreProgram
cbs
    f :: Bind Id -> Bool
f (NonRec Id
x Expr Id
_) = Id -> Bool
eqFd Id
x
    f (Rec [(Id, Expr Id)]
xes)    = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
eqFd ((Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Id, Expr Id)]
xes)
    eqFd :: Id -> Bool
eqFd Id
x         = Id -> Name
varName Id
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Name
varName Id
fd
    deps :: [Id]
deps           = (Unfolding -> [Id]) -> [Unfolding] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unfolding -> [Id]
unfoldDep [Unfolding]
unfolds
    unfolds :: [Unfolding]
unfolds        = IdInfo -> Unfolding
unfoldingInfo (IdInfo -> Unfolding) -> (Id -> IdInfo) -> Id -> Unfolding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo (Id -> Unfolding) -> [Id] -> [Unfolding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bind Id -> [Id]) -> CoreProgram -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
bindersOf CoreProgram
cbs'

unfoldDep :: Unfolding -> [Id]
unfoldDep :: Unfolding -> [Id]
unfoldDep (DFunUnfolding [Id]
_ DataCon
_ [Expr Id]
e)       = (Expr Id -> [Id]) -> [Expr Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr Id -> [Id]
exprDep [Expr Id]
e
unfoldDep CoreUnfolding {uf_tmpl :: Unfolding -> Expr Id
uf_tmpl = Expr Id
e} = Expr Id -> [Id]
exprDep Expr Id
e
unfoldDep Unfolding
_                           = []

exprDep :: CoreExpr -> [Id]
exprDep :: Expr Id -> [Id]
exprDep = HashSet Id -> Expr Id -> [Id]
forall a. CBVisitable a => HashSet Id -> a -> [Id]
freeVars HashSet Id
forall a. HashSet a
S.empty

importVars :: CoreProgram -> [Id]
importVars :: CoreProgram -> [Id]
importVars = HashSet Id -> CoreProgram -> [Id]
forall a. CBVisitable a => HashSet Id -> a -> [Id]
freeVars HashSet Id
forall a. HashSet a
S.empty

_definedVars :: CoreProgram -> [Id]
_definedVars :: CoreProgram -> [Id]
_definedVars = (Bind Id -> [Id]) -> CoreProgram -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
defs
  where
    defs :: Bind b -> [b]
defs (NonRec b
x Expr b
_) = [b
x]
    defs (Rec [(b, Expr b)]
xes)    = ((b, Expr b) -> b) -> [(b, Expr b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> b
forall a b. (a, b) -> a
fst [(b, Expr b)]
xes

--------------------------------------------------------------------------------
-- | Per-Module Pipeline -------------------------------------------------------
--------------------------------------------------------------------------------

type SpecEnv = ModuleEnv (ModName, Ms.BareSpec)

processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [TargetInfo]
processModules :: Config
-> LogicMap
-> [FilePath]
-> DepGraph
-> ModuleGraph
-> Ghc [TargetInfo]
processModules Config
cfg LogicMap
logicMap [FilePath]
tgtFiles DepGraph
depGraph ModuleGraph
homeModules = do
  -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles
  [Maybe TargetInfo] -> [TargetInfo]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TargetInfo] -> [TargetInfo])
-> ((SpecEnv, [Maybe TargetInfo]) -> [Maybe TargetInfo])
-> (SpecEnv, [Maybe TargetInfo])
-> [TargetInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecEnv, [Maybe TargetInfo]) -> [Maybe TargetInfo]
forall a b. (a, b) -> b
snd ((SpecEnv, [Maybe TargetInfo]) -> [TargetInfo])
-> Ghc (SpecEnv, [Maybe TargetInfo]) -> Ghc [TargetInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SpecEnv -> ModSummary -> Ghc (SpecEnv, Maybe TargetInfo))
-> SpecEnv -> [ModSummary] -> Ghc (SpecEnv, [Maybe TargetInfo])
forall (m :: * -> *) (t :: * -> *) a b c.
(Monad m, Traversable t) =>
(a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
Misc.mapAccumM SpecEnv -> ModSummary -> Ghc (SpecEnv, Maybe TargetInfo)
go SpecEnv
forall a. ModuleEnv a
emptyModuleEnv (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
homeModules)
  where                                             
    go :: SpecEnv -> ModSummary -> Ghc (SpecEnv, Maybe TargetInfo)
go = Config
-> LogicMap
-> HashSet FilePath
-> DepGraph
-> SpecEnv
-> ModSummary
-> Ghc (SpecEnv, Maybe TargetInfo)
processModule Config
cfg LogicMap
logicMap ([FilePath] -> HashSet FilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [FilePath]
tgtFiles) DepGraph
depGraph

processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary
              -> Ghc (SpecEnv, Maybe TargetInfo)
processModule :: Config
-> LogicMap
-> HashSet FilePath
-> DepGraph
-> SpecEnv
-> ModSummary
-> Ghc (SpecEnv, Maybe TargetInfo)
processModule Config
cfg LogicMap
logicMap HashSet FilePath
tgtFiles DepGraph
depGraph SpecEnv
specEnv ModSummary
modSummary = do
  let mod :: Module
mod              = ModSummary -> Module
ms_mod ModSummary
modSummary
  -- DO-NOT-DELETE _                <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)
  FilePath
file                <- IO FilePath -> Ghc FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Ghc FilePath) -> IO FilePath -> Ghc FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> FilePath
modSummaryHsFile ModSummary
modSummary
  let isTarget :: Bool
isTarget         = FilePath
file FilePath -> HashSet FilePath -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet FilePath
tgtFiles
  ()
_                   <- ModuleName -> Ghc ()
forall (m :: * -> *). GhcMonad m => ModuleName -> m ()
loadDependenciesOf (ModuleName -> Ghc ()) -> ModuleName -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
mod
  ParsedModule
parsed              <- ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule (ModSummary -> Ghc ParsedModule) -> ModSummary -> Ghc ParsedModule
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModSummary
keepRawTokenStream ModSummary
modSummary
  let specComments :: [(SourcePos, FilePath)]
specComments     = ApiAnns -> [(SourcePos, FilePath)]
extractSpecComments (ParsedModule -> ApiAnns
pm_annotations ParsedModule
parsed)
  TypecheckedModule
typechecked         <- ParsedModule -> Ghc TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule (ParsedModule -> Ghc TypecheckedModule)
-> ParsedModule -> Ghc TypecheckedModule
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedModule
ignoreInline ParsedModule
parsed
  let specQuotes :: [BPspec]
specQuotes       = TypecheckedModule -> [BPspec]
extractSpecQuotes TypecheckedModule
typechecked
  TypecheckedModule
_                   <- TypecheckedModule -> Ghc TypecheckedModule
loadModule' TypecheckedModule
typechecked
  (ModName
modName, BareSpec
commSpec) <- ([Error] -> Ghc (ModName, BareSpec))
-> ((ModName, BareSpec) -> Ghc (ModName, BareSpec))
-> Either [Error] (ModName, BareSpec)
-> Ghc (ModName, BareSpec)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Error] -> Ghc (ModName, BareSpec)
forall a e. Exception e => e -> a
throw (ModName, BareSpec) -> Ghc (ModName, BareSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Error] (ModName, BareSpec) -> Ghc (ModName, BareSpec))
-> Either [Error] (ModName, BareSpec) -> Ghc (ModName, BareSpec)
forall a b. (a -> b) -> a -> b
$ ModuleName
-> [(SourcePos, FilePath)]
-> [BPspec]
-> Either [Error] (ModName, BareSpec)
hsSpecificationP (Module -> ModuleName
moduleName Module
mod) [(SourcePos, FilePath)]
specComments [BPspec]
specQuotes

  Maybe BareSpec
liftedSpec          <- IO (Maybe BareSpec) -> Ghc (Maybe BareSpec)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe BareSpec) -> Ghc (Maybe BareSpec))
-> IO (Maybe BareSpec) -> Ghc (Maybe BareSpec)
forall a b. (a -> b) -> a -> b
$ if Bool
isTarget Bool -> Bool -> Bool
|| [(SourcePos, FilePath)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SourcePos, FilePath)]
specComments then Maybe BareSpec -> IO (Maybe BareSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BareSpec
forall a. Maybe a
Nothing else Config -> FilePath -> IO (Maybe BareSpec)
loadLiftedSpec Config
cfg FilePath
file 
  let bareSpec :: BareSpec
bareSpec         = BareSpec -> Maybe BareSpec -> BareSpec
updLiftedSpec BareSpec
commSpec Maybe BareSpec
liftedSpec
  ()
_                   <- [Located FilePath] -> Ghc ()
forall (m :: * -> *). GhcMonadLike m => [Located FilePath] -> m ()
checkFilePragmas ([Located FilePath] -> Ghc ()) -> [Located FilePath] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ BareSpec -> [Located FilePath]
forall ty bndr. Spec ty bndr -> [Located FilePath]
Ms.pragmas BareSpec
bareSpec
  let specEnv' :: SpecEnv
specEnv'         = SpecEnv -> Module -> (ModName, BareSpec) -> SpecEnv
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv SpecEnv
specEnv Module
mod (ModName
modName, BareSpec -> BareSpec
noTerm BareSpec
bareSpec)
  (SpecEnv
specEnv', ) (Maybe TargetInfo -> (SpecEnv, Maybe TargetInfo))
-> Ghc (Maybe TargetInfo) -> Ghc (SpecEnv, Maybe TargetInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
isTarget
                     then TargetInfo -> Maybe TargetInfo
forall a. a -> Maybe a
Just (TargetInfo -> Maybe TargetInfo)
-> Ghc TargetInfo -> Ghc (Maybe TargetInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config
-> LogicMap
-> DepGraph
-> SpecEnv
-> FilePath
-> TypecheckedModule
-> BareSpec
-> Ghc TargetInfo
processTargetModule Config
cfg LogicMap
logicMap DepGraph
depGraph SpecEnv
specEnv FilePath
file TypecheckedModule
typechecked BareSpec
bareSpec
                     else Maybe TargetInfo -> Ghc (Maybe TargetInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TargetInfo
forall a. Maybe a
Nothing

updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec 
updLiftedSpec :: BareSpec -> Maybe BareSpec -> BareSpec
updLiftedSpec BareSpec
s1 Maybe BareSpec
Nothing   = BareSpec
s1 
updLiftedSpec BareSpec
s1 (Just BareSpec
s2) = (BareSpec -> BareSpec
clearSpec BareSpec
s1) BareSpec -> BareSpec -> BareSpec
forall a. Monoid a => a -> a -> a
`mappend` BareSpec
s2 

clearSpec :: Ms.BareSpec -> Ms.BareSpec
clearSpec :: BareSpec -> BareSpec
clearSpec BareSpec
s = BareSpec
s { sigs :: [(LocSymbol, LocBareType)]
sigs = [], asmSigs :: [(LocSymbol, LocBareType)]
asmSigs = [], aliases :: [Located (RTAlias Symbol BareType)]
aliases = [], ealiases :: [Located (RTAlias Symbol Expr)]
ealiases = [], qualifiers :: [Qualifier]
qualifiers = [], dataDecls :: [DataDecl]
dataDecls = [] }

keepRawTokenStream :: ModSummary -> ModSummary
keepRawTokenStream :: ModSummary -> ModSummary
keepRawTokenStream ModSummary
modSummary = ModSummary
modSummary
  { ms_hspp_opts :: DynFlags
ms_hspp_opts = ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream }

loadDependenciesOf :: GhcMonad m => ModuleName -> m ()
loadDependenciesOf :: ModuleName -> m ()
loadDependenciesOf ModuleName
modName = do
  SuccessFlag
loadResult <- LoadHowMuch -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load (LoadHowMuch -> m SuccessFlag) -> LoadHowMuch -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ ModuleName -> LoadHowMuch
LoadDependenciesOf ModuleName
modName
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
loadResult) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$
   FilePath
"Failed to load dependencies of module " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
forall a. Outputable a => a -> FilePath
showPpr ModuleName
modName

loadModule' :: TypecheckedModule -> Ghc TypecheckedModule
loadModule' :: TypecheckedModule -> Ghc TypecheckedModule
loadModule' TypecheckedModule
tm = TypecheckedModule -> Ghc TypecheckedModule
forall mod (m :: * -> *).
(TypecheckedMod mod, GhcMonad m) =>
mod -> m mod
loadModule TypecheckedModule
tm'
  where
    pm :: ParsedModule
pm   = TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
tm
    ms :: ModSummary
ms   = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm
    df :: DynFlags
df   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
    df' :: DynFlags
df'  = DynFlags
df { hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing, ghcLink :: GhcLink
ghcLink = GhcLink
NoLink }
    ms' :: ModSummary
ms'  = ModSummary
ms { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
df' }
    pm' :: ParsedModule
pm'  = ParsedModule
pm { pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
ms' }
    tm' :: TypecheckedModule
tm'  = TypecheckedModule
tm { tm_parsed_module :: ParsedModule
tm_parsed_module = ParsedModule
pm' }


processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec
                    -> Ghc TargetInfo
processTargetModule :: Config
-> LogicMap
-> DepGraph
-> SpecEnv
-> FilePath
-> TypecheckedModule
-> BareSpec
-> Ghc TargetInfo
processTargetModule Config
cfg0 LogicMap
logicMap DepGraph
depGraph SpecEnv
specEnv FilePath
file TypecheckedModule
typechecked BareSpec
bareSpec = do
  Config
cfg          <- IO Config -> Ghc Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> Ghc Config) -> IO Config -> Ghc Config
forall a b. (a -> b) -> a -> b
$ Config -> FilePath -> [Located FilePath] -> IO Config
withPragmas Config
cfg0 FilePath
file (BareSpec -> [Located FilePath]
forall ty bndr. Spec ty bndr -> [Located FilePath]
Ms.pragmas BareSpec
bareSpec)
  let modSum :: ModSummary
modSum    = ParsedModule -> ModSummary
pm_mod_summary (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
typechecked)
  GhcSrc
ghcSrc       <- Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc
makeGhcSrc    Config
cfg FilePath
file     TypecheckedModule
typechecked ModSummary
modSum
  TargetDependencies
dependencies <- Config
-> DepGraph
-> SpecEnv
-> ModSummary
-> BareSpec
-> Ghc TargetDependencies
makeDependencies Config
cfg DepGraph
depGraph SpecEnv
specEnv ModSummary
modSum BareSpec
bareSpec

  let targetSrc :: TargetSrc
targetSrc = Optic' An_Iso NoIx GhcSrc TargetSrc -> GhcSrc -> TargetSrc
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx GhcSrc TargetSrc
targetSrcIso GhcSrc
ghcSrc
  DynFlags
dynFlags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

  case Config
-> LogicMap
-> TargetSrc
-> BareSpec
-> TargetDependencies
-> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
makeTargetSpec Config
cfg LogicMap
logicMap TargetSrc
targetSrc (Optic' An_Iso NoIx BareSpec BareSpec -> BareSpec -> BareSpec
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx BareSpec BareSpec
bareSpecIso BareSpec
bareSpec) TargetDependencies
dependencies of
    Left Diagnostics
diagnostics -> do
      (Warning -> Ghc ()) -> [Warning] -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> (Warning -> IO ()) -> Warning -> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Warning -> IO ()
printWarning DynFlags
dynFlags) (Diagnostics -> [Warning]
allWarnings Diagnostics
diagnostics)
      [Error] -> Ghc TargetInfo
forall a e. Exception e => e -> a
throw (Diagnostics -> [Error]
allErrors Diagnostics
diagnostics)
    Right ([Warning]
warns, TargetSpec
targetSpec, LiftedSpec
liftedSpec) -> do
      (Warning -> Ghc ()) -> [Warning] -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> (Warning -> IO ()) -> Warning -> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Warning -> IO ()
printWarning DynFlags
dynFlags) [Warning]
warns
      -- The call below is temporary, we should really load & save directly 'LiftedSpec's.
      ()
_          <- IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> BareSpec -> IO ()
saveLiftedSpec (GhcSrc -> FilePath
_giTarget GhcSrc
ghcSrc) (LiftedSpec -> BareSpec
unsafeFromLiftedSpec LiftedSpec
liftedSpec)
      TargetInfo -> Ghc TargetInfo
forall (m :: * -> *) a. Monad m => a -> m a
return      (TargetInfo -> Ghc TargetInfo) -> TargetInfo -> Ghc TargetInfo
forall a b. (a -> b) -> a -> b
$ TargetSrc -> TargetSpec -> TargetInfo
TargetInfo TargetSrc
targetSrc TargetSpec
targetSpec

---------------------------------------------------------------------------------------
-- | @makeGhcSrc@ builds all the source-related information needed for consgen 
---------------------------------------------------------------------------------------

makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc 
makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc
makeGhcSrc Config
cfg FilePath
file TypecheckedModule
typechecked ModSummary
modSum = do
  ModGuts
modGuts'          <- ModSummary -> TypecheckedModule -> Ghc ModGuts
forall (m :: * -> *) t.
(GhcMonadLike m, IsTypecheckedModule t) =>
ModSummary -> t -> m ModGuts
GhcMonadLike.desugarModule ModSummary
modSum TypecheckedModule
typechecked

  let modGuts :: MGIModGuts
modGuts        = ModGuts -> MGIModGuts
makeMGIModGuts ModGuts
modGuts'
  HscEnv
hscEnv            <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  CoreProgram
coreBinds         <- IO CoreProgram -> Ghc CoreProgram
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CoreProgram -> Ghc CoreProgram)
-> IO CoreProgram -> Ghc CoreProgram
forall a b. (a -> b) -> a -> b
$ Config -> HscEnv -> ModGuts -> IO CoreProgram
anormalize Config
cfg HscEnv
hscEnv ModGuts
modGuts'
  ()
_                 <- IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
whenNormal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Moods -> FilePath -> IO ()
Misc.donePhase Moods
Misc.Loud FilePath
"A-Normalization"
  let dataCons :: [Id]
dataCons       = (TyCon -> [Id]) -> [TyCon] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((DataCon -> Id) -> [DataCon] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Id
dataConWorkId ([DataCon] -> [Id]) -> (TyCon -> [DataCon]) -> TyCon -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons) (MGIModGuts -> [TyCon]
mgi_tcs MGIModGuts
modGuts)
  ([TyCon]
fiTcs, [(Symbol, DataCon)]
fiDcs)    <- [FamInst] -> ([TyCon], [(Symbol, DataCon)])
makeFamInstEnv ([FamInst] -> ([TyCon], [(Symbol, DataCon)]))
-> Ghc [FamInst] -> Ghc ([TyCon], [(Symbol, DataCon)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FamInst] -> Ghc [FamInst]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> IO [FamInst]
getFamInstances HscEnv
hscEnv)
  [(Name, Maybe TyThing)]
things            <- HscEnv -> ModSummary -> TcGblEnv -> Ghc [(Name, Maybe TyThing)]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]
lookupTyThings HscEnv
hscEnv ModSummary
modSum ((TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
typechecked)

  [TyCon]
availableTcs      <- HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> Ghc [TyCon]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyCon]
availableTyCons HscEnv
hscEnv ModSummary
modSum ((TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
typechecked) (ModGuts -> [AvailInfo]
mg_exports ModGuts
modGuts')

  let impVars :: [Id]
impVars        = CoreProgram -> [Id]
importVars CoreProgram
coreBinds [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ Maybe [ClsInst] -> [Id]
classCons (MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst MGIModGuts
modGuts)
  FilePath
incDir            <- IO FilePath -> Ghc FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Ghc FilePath) -> IO FilePath -> Ghc FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
Misc.getIncludeDir

  --liftIO $ do
  --  print $ "_gsTcs   => " ++ show (nub $ (mgi_tcs      modGuts) ++ availableTcs)
  --  print $ "_gsFiTcs => " ++ show fiTcs
  --  print $ "_gsFiDcs => " ++ show fiDcs
  --  print $ "dataCons => " ++ show dataCons
  --  print $ "defVars  => " ++ show (dataCons ++ (letVars coreBinds))

  GhcSrc -> Ghc GhcSrc
forall (m :: * -> *) a. Monad m => a -> m a
return (GhcSrc -> Ghc GhcSrc) -> GhcSrc -> Ghc GhcSrc
forall a b. (a -> b) -> a -> b
$ Src :: FilePath
-> FilePath
-> ModName
-> CoreProgram
-> [TyCon]
-> Maybe [ClsInst]
-> HashSet Id
-> [Id]
-> [Id]
-> [Id]
-> HashSet StableName
-> [TyCon]
-> [(Symbol, DataCon)]
-> [TyCon]
-> QImports
-> HashSet Symbol
-> [TyThing]
-> GhcSrc
Src 
    { _giIncDir :: FilePath
_giIncDir    = FilePath
incDir 
    , _giTarget :: FilePath
_giTarget    = FilePath
file
    , _giTargetMod :: ModName
_giTargetMod = ModType -> ModuleName -> ModName
ModName ModType
Target (Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
modSum))
    , _giCbs :: CoreProgram
_giCbs       = CoreProgram
coreBinds
    , _giImpVars :: [Id]
_giImpVars   = [Id]
impVars 
    , _giDefVars :: [Id]
_giDefVars   = [Id]
dataCons [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (CoreProgram -> [Id]
forall a. CBVisitable a => a -> [Id]
letVars CoreProgram
coreBinds) 
    , _giUseVars :: [Id]
_giUseVars   = CoreProgram -> [Id]
forall a. CBVisitable a => a -> [Id]
readVars CoreProgram
coreBinds
    , _giDerVars :: HashSet Id
_giDerVars   = [Id] -> HashSet Id
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (Config -> MGIModGuts -> [Id]
derivedVars Config
cfg MGIModGuts
modGuts) 
    , _gsExports :: HashSet StableName
_gsExports   = MGIModGuts -> HashSet StableName
mgi_exports  MGIModGuts
modGuts 
    , _gsTcs :: [TyCon]
_gsTcs       = [TyCon] -> [TyCon]
forall a. Eq a => [a] -> [a]
nub ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$ (MGIModGuts -> [TyCon]
mgi_tcs      MGIModGuts
modGuts) [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [TyCon]
availableTcs
    , _gsCls :: Maybe [ClsInst]
_gsCls       = MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst MGIModGuts
modGuts 
    , _gsFiTcs :: [TyCon]
_gsFiTcs     = [TyCon]
fiTcs 
    , _gsFiDcs :: [(Symbol, DataCon)]
_gsFiDcs     = [(Symbol, DataCon)]
fiDcs
    , _gsPrimTcs :: [TyCon]
_gsPrimTcs   = [TyCon]
TysPrim.primTyCons
    , _gsQualImps :: QImports
_gsQualImps  = [LImportDecl GhcRn] -> QImports
qualifiedImports ([LImportDecl GhcRn]
-> (RenamedSource -> [LImportDecl GhcRn])
-> Maybe RenamedSource
-> [LImportDecl GhcRn]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [LImportDecl GhcRn]
forall a. Monoid a => a
mempty (Optic' A_Lens NoIx RenamedSource [LImportDecl GhcRn]
-> RenamedSource -> [LImportDecl GhcRn]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx RenamedSource [LImportDecl GhcRn]
forall s t a b. Field2 s t a b => Lens s t a b
_2) (TypecheckedModule -> Maybe RenamedSource
tm_renamed_source TypecheckedModule
typechecked))
    , _gsAllImps :: HashSet Symbol
_gsAllImps   = [LImportDecl GhcRn] -> HashSet Symbol
allImports       ([LImportDecl GhcRn]
-> (RenamedSource -> [LImportDecl GhcRn])
-> Maybe RenamedSource
-> [LImportDecl GhcRn]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [LImportDecl GhcRn]
forall a. Monoid a => a
mempty (Optic' A_Lens NoIx RenamedSource [LImportDecl GhcRn]
-> RenamedSource -> [LImportDecl GhcRn]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx RenamedSource [LImportDecl GhcRn]
forall s t a b. Field2 s t a b => Lens s t a b
_2) (TypecheckedModule -> Maybe RenamedSource
tm_renamed_source TypecheckedModule
typechecked))
    , _gsTyThings :: [TyThing]
_gsTyThings  = [ TyThing
t | (Name
_, Just TyThing
t) <- [(Name, Maybe TyThing)]
things ] 
    }

_impThings :: [Var] -> [TyThing] -> [TyThing]
_impThings :: [Id] -> [TyThing] -> [TyThing]
_impThings [Id]
vars  = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filter TyThing -> Bool
ok
  where
    vs :: HashSet Id
vs          = [Id] -> HashSet Id
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Id]
vars 
    ok :: TyThing -> Bool
ok (AnId Id
x) = Id -> HashSet Id -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Id
x HashSet Id
vs  
    ok TyThing
_        = Bool
True 

allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol 
allImports :: [LImportDecl GhcRn] -> HashSet Symbol
allImports = \case
  []-> FilePath -> HashSet Symbol -> HashSet Symbol
forall a. FilePath -> a -> a
Debug.trace FilePath
"WARNING: Missing RenamedSource" HashSet Symbol
forall a. Monoid a => a
mempty 
  [LImportDecl GhcRn]
imps -> [Symbol] -> HashSet Symbol
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (ModuleName -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (ModuleName -> Symbol)
-> (LImportDecl GhcRn -> ModuleName) -> LImportDecl GhcRn -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> (LImportDecl GhcRn -> Located ModuleName)
-> LImportDecl GhcRn
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcRn -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName (ImportDecl GhcRn -> Located ModuleName)
-> (LImportDecl GhcRn -> ImportDecl GhcRn)
-> LImportDecl GhcRn
-> Located ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcRn -> ImportDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LImportDecl GhcRn -> Symbol) -> [LImportDecl GhcRn] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LImportDecl GhcRn]
imps)

qualifiedImports :: [LImportDecl GhcRn] -> QImports 
qualifiedImports :: [LImportDecl GhcRn] -> QImports
qualifiedImports = \case
  []   -> FilePath -> QImports -> QImports
forall a. FilePath -> a -> a
Debug.trace FilePath
"WARNING: Missing RenamedSource" ([(Symbol, Symbol)] -> QImports
qImports [(Symbol, Symbol)]
forall a. Monoid a => a
mempty) 
  [LImportDecl GhcRn]
imps -> [(Symbol, Symbol)] -> QImports
qImports [ (Symbol
qn, Symbol
n) | LImportDecl GhcRn
i         <- [LImportDecl GhcRn]
imps
                                          , let decl :: SrcSpanLess (LImportDecl GhcRn)
decl   = LImportDecl GhcRn -> SrcSpanLess (LImportDecl GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LImportDecl GhcRn
i
                                          , let m :: SrcSpanLess (Located ModuleName)
m      = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcRn -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcRn
decl)  
                                          , ModuleName
qm        <- Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
maybeToList (Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportDecl GhcRn -> Maybe (Located ModuleName)
forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclAs ImportDecl GhcRn
decl) 
                                          , let [Symbol
n,Symbol
qn] = ModuleName -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (ModuleName -> Symbol) -> [ModuleName] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName
m, ModuleName
qm] 
                                          ]

qImports :: [(Symbol, Symbol)] -> QImports 
qImports :: [(Symbol, Symbol)] -> QImports
qImports [(Symbol, Symbol)]
qns  = QImports :: HashSet Symbol -> HashMap Symbol [Symbol] -> QImports
QImports 
  { qiNames :: HashMap Symbol [Symbol]
qiNames   = [(Symbol, Symbol)] -> HashMap Symbol [Symbol]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
Misc.group [(Symbol, Symbol)]
qns 
  , qiModules :: HashSet Symbol
qiModules = [Symbol] -> HashSet Symbol
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ((Symbol, Symbol) -> Symbol
forall a b. (a, b) -> b
snd ((Symbol, Symbol) -> Symbol) -> [(Symbol, Symbol)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Symbol, Symbol)]
qns) 
  }


---------------------------------------------------------------------------------------
-- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC 
--   for this module; we will use this to create our name-resolution environment 
--   (see `Bare.Resolve`)                                          
---------------------------------------------------------------------------------------
lookupTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]
lookupTyThings :: HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]
lookupTyThings HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv = [Name]
-> (Name -> m (Name, Maybe TyThing)) -> m [(Name, Maybe TyThing)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names (HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv)
  where
    names :: [Ghc.Name] 
    names :: [Name]
names  = (GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrElt -> Name
Ghc.gre_name ([GlobalRdrElt] -> [Name])
-> (GlobalRdrEnv -> [GlobalRdrElt]) -> GlobalRdrEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [GlobalRdrElt]
Ghc.globalRdrEnvElts (GlobalRdrEnv -> [Name]) -> GlobalRdrEnv -> [Name]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcGblEnv

-- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',
-- if one is found.
lookupTyThing :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
lookupTyThing :: HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv Name
n = do
  ModuleInfo
mi  <- ModSummary -> TcGblEnv -> m ModuleInfo
forall (m :: * -> *).
GhcMonadLike m =>
ModSummary -> TcGblEnv -> m ModuleInfo
GhcMonadLike.moduleInfoTc ModSummary
modSum TcGblEnv
tcGblEnv
  Maybe TyThing
tt1 <-          Name -> m (Maybe TyThing)
forall (m :: * -> *). GhcMonadLike m => Name -> m (Maybe TyThing)
GhcMonadLike.lookupName      Name
n
  Maybe TyThing
tt2 <- IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
Ghc.hscTcRcLookupName HscEnv
hscEnv Name
n
  Maybe TyThing
tt3 <-          ModuleInfo -> Name -> m (Maybe TyThing)
forall (m :: * -> *).
GhcMonadLike m =>
ModuleInfo -> Name -> m (Maybe TyThing)
GhcMonadLike.modInfoLookupName ModuleInfo
mi Name
n
  Maybe TyThing
tt4 <-          Name -> m (Maybe TyThing)
forall (m :: * -> *). GhcMonadLike m => Name -> m (Maybe TyThing)
GhcMonadLike.lookupGlobalName Name
n
  (Name, Maybe TyThing) -> m (Name, Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, [Maybe TyThing] -> Maybe TyThing
forall a. [Maybe a] -> Maybe a
Misc.firstMaybes [Maybe TyThing
tt1, Maybe TyThing
tt2, Maybe TyThing
tt3, Maybe TyThing
tt4])

availableTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
availableTyThings :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
availableTyThings HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv [AvailInfo]
avails = ([[Maybe TyThing]] -> [TyThing])
-> m [[Maybe TyThing]] -> m [TyThing]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TyThing] -> [TyThing])
-> ([[Maybe TyThing]] -> [Maybe TyThing])
-> [[Maybe TyThing]]
-> [TyThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe TyThing]] -> [Maybe TyThing]
forall a. Monoid a => [a] -> a
mconcat) (m [[Maybe TyThing]] -> m [TyThing])
-> m [[Maybe TyThing]] -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ [AvailInfo]
-> (AvailInfo -> m [Maybe TyThing]) -> m [[Maybe TyThing]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AvailInfo]
avails ((AvailInfo -> m [Maybe TyThing]) -> m [[Maybe TyThing]])
-> (AvailInfo -> m [Maybe TyThing]) -> m [[Maybe TyThing]]
forall a b. (a -> b) -> a -> b
$ \AvailInfo
a -> do
  [(Name, Maybe TyThing)]
results <- case AvailInfo
a of
    Avail Name
n        -> (Name, Maybe TyThing) -> [(Name, Maybe TyThing)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Maybe TyThing) -> [(Name, Maybe TyThing)])
-> m (Name, Maybe TyThing) -> m [(Name, Maybe TyThing)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv Name
n
    AvailTC Name
n [Name]
ns [FieldLabel]
_ -> [Name]
-> (Name -> m (Name, Maybe TyThing)) -> m [(Name, Maybe TyThing)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ns) ((Name -> m (Name, Maybe TyThing)) -> m [(Name, Maybe TyThing)])
-> (Name -> m (Name, Maybe TyThing)) -> m [(Name, Maybe TyThing)]
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv
  [Maybe TyThing] -> m [Maybe TyThing]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe TyThing] -> m [Maybe TyThing])
-> ([(Name, Maybe TyThing)] -> [Maybe TyThing])
-> [(Name, Maybe TyThing)]
-> m [Maybe TyThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Maybe TyThing) -> Maybe TyThing)
-> [(Name, Maybe TyThing)] -> [Maybe TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Maybe TyThing) -> Maybe TyThing
forall a b. (a, b) -> b
snd ([(Name, Maybe TyThing)] -> m [Maybe TyThing])
-> [(Name, Maybe TyThing)] -> m [Maybe TyThing]
forall a b. (a -> b) -> a -> b
$ [(Name, Maybe TyThing)]
results

-- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.
availableTyCons :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [GHC.TyCon]
availableTyCons :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyCon]
availableTyCons HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv [AvailInfo]
avails = 
  ([TyThing] -> [TyCon]) -> m [TyThing] -> m [TyCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TyThing]
things -> [TyCon
tyCon | (ATyCon TyCon
tyCon) <- [TyThing]
things]) (HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
availableTyThings HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv [AvailInfo]
avails)

-- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.
availableVars :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.Var]
availableVars :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Id]
availableVars HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv [AvailInfo]
avails = 
  ([TyThing] -> [Id]) -> m [TyThing] -> m [Id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TyThing]
things -> [Id
var | (AnId Id
var) <- [TyThing]
things]) (HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
availableTyThings HscEnv
hscEnv ModSummary
modSum TcGblEnv
tcGblEnv [AvailInfo]
avails)

-- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing) 
-- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
-- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)  
-- lookupGlobalName  :: GhcMonad m => Name -> m (Maybe TyThing)  

_dumpTypeEnv :: TypecheckedModule -> IO () 
_dumpTypeEnv :: TypecheckedModule -> IO ()
_dumpTypeEnv TypecheckedModule
tm = do 
  FilePath -> IO ()
forall a. Show a => a -> IO ()
print FilePath
"DUMP-TYPE-ENV"
  Maybe FilePath -> IO ()
forall a. Show a => a -> IO ()
print ([Name] -> FilePath
forall a. PPrint a => a -> FilePath
showpp ([Name] -> FilePath) -> Maybe [Name] -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypecheckedModule -> Maybe [Name]
tcmTyThings TypecheckedModule
tm)

tcmTyThings :: TypecheckedModule -> Maybe [Name] 
tcmTyThings :: TypecheckedModule -> Maybe [Name]
tcmTyThings 
  = Maybe [Name] -> Maybe [Name]
forall a. a -> a
id 
  -- typeEnvElts 
  -- . tcg_type_env . fst 
  -- . md_types . snd
  -- . tm_internals_
  (Maybe [Name] -> Maybe [Name])
-> (TypecheckedModule -> Maybe [Name])
-> TypecheckedModule
-> Maybe [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> Maybe [Name]
modInfoTopLevelScope
  (ModuleInfo -> Maybe [Name])
-> (TypecheckedModule -> ModuleInfo)
-> TypecheckedModule
-> Maybe [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ModuleInfo
tm_checked_module_info


_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO () 
_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO ()
_dumpRdrEnv HscEnv
_hscEnv MGIModGuts
modGuts = do 
  FilePath -> IO ()
forall a. Show a => a -> IO ()
print FilePath
"DUMP-RDR-ENV" 
  [Name] -> IO ()
forall a. Show a => a -> IO ()
print (MGIModGuts -> [Name]
mgNames MGIModGuts
modGuts)
  -- print (hscNames hscEnv) 
  -- print (mgDeps modGuts) 
  where 
    _mgDeps :: MGIModGuts -> [(ModuleName, Bool)]
_mgDeps   = Dependencies -> [(ModuleName, Bool)]
Ghc.dep_mods (Dependencies -> [(ModuleName, Bool)])
-> (MGIModGuts -> Dependencies)
-> MGIModGuts
-> [(ModuleName, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MGIModGuts -> Dependencies
mgi_deps 
    _hscNames :: HscEnv -> [FilePath]
_hscNames = (TyThing -> FilePath) -> [TyThing] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyThing -> FilePath
forall a. Outputable a => a -> FilePath
showPpr ([TyThing] -> [FilePath])
-> (HscEnv -> [TyThing]) -> HscEnv -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveContext -> [TyThing]
Ghc.ic_tythings (InteractiveContext -> [TyThing])
-> (HscEnv -> InteractiveContext) -> HscEnv -> [TyThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
Ghc.hsc_IC

mgNames :: MGIModGuts -> [Ghc.Name] 
mgNames :: MGIModGuts -> [Name]
mgNames  = (GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrElt -> Name
Ghc.gre_name ([GlobalRdrElt] -> [Name])
-> (MGIModGuts -> [GlobalRdrElt]) -> MGIModGuts -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [GlobalRdrElt]
Ghc.globalRdrEnvElts (GlobalRdrEnv -> [GlobalRdrElt])
-> (MGIModGuts -> GlobalRdrEnv) -> MGIModGuts -> [GlobalRdrElt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  MGIModGuts -> GlobalRdrEnv
mgi_rdr_env 

---------------------------------------------------------------------------------------
-- | @makeDependencies@ loads BareSpec for target and imported modules 
-- /IMPORTANT(adn)/: We \"cheat\" a bit by creating a 'Module' out the 'ModuleName' we 
-- parse from the spec, and convert the former into a 'StableModule' for the purpose
-- of dependency tracking. This means, in practice, that all the \"wired-in-prelude\"
-- specs will share the same `UnitId`, which for the sake of the executable is an
-- acceptable compromise, as long as we don't create duplicates.
---------------------------------------------------------------------------------------
makeDependencies :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec 
                 -> Ghc TargetDependencies
makeDependencies :: Config
-> DepGraph
-> SpecEnv
-> ModSummary
-> BareSpec
-> Ghc TargetDependencies
makeDependencies Config
cfg DepGraph
depGraph SpecEnv
specEnv ModSummary
modSum BareSpec
_ = do 
  let paths :: HashSet FilePath
paths     = [FilePath] -> HashSet FilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([FilePath] -> HashSet FilePath) -> [FilePath] -> HashSet FilePath
forall a b. (a -> b) -> a -> b
$ Config -> [FilePath]
idirs Config
cfg [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
importPaths (ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSum)
  ()
_            <- IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"paths = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HashSet FilePath -> FilePath
forall a. Show a => a -> FilePath
show HashSet FilePath
paths
  let reachable :: [Module]
reachable = DepGraph -> Module -> [Module]
reachableModules DepGraph
depGraph (ModSummary -> Module
ms_mod ModSummary
modSum)
  [(ModName, BareSpec)]
specSpecs    <- Config
-> HashSet FilePath
-> ModSummary
-> [Module]
-> Ghc [(ModName, BareSpec)]
forall (m :: * -> *).
GhcMonadLike m =>
Config
-> HashSet FilePath
-> ModSummary
-> [Module]
-> m [(ModName, BareSpec)]
findAndParseSpecFiles Config
cfg HashSet FilePath
paths ModSummary
modSum [Module]
reachable
  let homeSpecs :: [(ModName, BareSpec)]
homeSpecs = SpecEnv -> [Module] -> [(ModName, BareSpec)]
cachedBareSpecs SpecEnv
specEnv [Module]
reachable

  -- NOTE:(adn) Unfortunately for the executable we might have 3 different 'Prelude' specs
  -- (one for the Prelude functions, one for the Real/NonReal and one for the PatErr, so we
  -- cannot really assume all the module names will be disjointed. As a result we have to
  -- hack our way around this by replacing the 'UnitId' with some unique enumeration, at
  -- least unique in this local scope.

  let combine :: b -> (a, b) -> ((a, b), b)
combine b
ix (a
mn, b
sp) = ((a
mn, b
ix), b
sp)
  let impSpecs :: [(StableModule, LiftedSpec)]
impSpecs  = (((ModName, Int), BareSpec) -> (StableModule, LiftedSpec))
-> [((ModName, Int), BareSpec)] -> [(StableModule, LiftedSpec)]
forall a b. (a -> b) -> [a] -> [b]
map (((ModName, Int) -> StableModule)
-> (BareSpec -> LiftedSpec)
-> ((ModName, Int), BareSpec)
-> (StableModule, LiftedSpec)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ModName, Int) -> StableModule
mkStableModule (Optic' A_Getter NoIx BareSpec LiftedSpec -> BareSpec -> LiftedSpec
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter NoIx BareSpec LiftedSpec
liftedSpecGetter)) ((Int -> (ModName, BareSpec) -> ((ModName, Int), BareSpec))
-> [Int] -> [(ModName, BareSpec)] -> [((ModName, Int), BareSpec)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (ModName, BareSpec) -> ((ModName, Int), BareSpec)
forall b a b. b -> (a, b) -> ((a, b), b)
combine [Int
0..] ([(ModName, BareSpec)]
specSpecs [(ModName, BareSpec)]
-> [(ModName, BareSpec)] -> [(ModName, BareSpec)]
forall a. [a] -> [a] -> [a]
++ [(ModName, BareSpec)]
homeSpecs))

  TargetDependencies -> Ghc TargetDependencies
forall (m :: * -> *) a. Monad m => a -> m a
return        (TargetDependencies -> Ghc TargetDependencies)
-> TargetDependencies -> Ghc TargetDependencies
forall a b. (a -> b) -> a -> b
$ HashMap StableModule LiftedSpec -> TargetDependencies
TargetDependencies (HashMap StableModule LiftedSpec -> TargetDependencies)
-> HashMap StableModule LiftedSpec -> TargetDependencies
forall a b. (a -> b) -> a -> b
$ [(StableModule, LiftedSpec)] -> HashMap StableModule LiftedSpec
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(StableModule, LiftedSpec)]
impSpecs
  where
    mkStableModule :: (ModName, Int) -> StableModule
    mkStableModule :: (ModName, Int) -> StableModule
mkStableModule (ModName
modName, Int
ix) = 
      Module -> StableModule
toStableModule (UnitId -> ModuleName -> Module
Module (UnitId -> Int -> UnitId
fakeUnitId (Module -> UnitId
moduleUnitId Module
targetModule) Int
ix) (ModName -> ModuleName
getModName ModName
modName))

    fakeUnitId :: UnitId -> Int -> UnitId
    fakeUnitId :: UnitId -> Int -> UnitId
fakeUnitId UnitId
uid Int
ix = FilePath -> UnitId
stringToUnitId (FilePath -> UnitId) -> FilePath -> UnitId
forall a b. (a -> b) -> a -> b
$ UnitId -> FilePath
unitIdString UnitId
uid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
ix

    targetModule :: Module
    targetModule :: Module
targetModule = ModSummary -> Module
ms_mod ModSummary
modSum

modSummaryHsFile :: ModSummary -> FilePath
modSummaryHsFile :: ModSummary -> FilePath
modSummaryHsFile ModSummary
modSummary =
  FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe
    (Maybe SrcSpan -> FilePath -> FilePath
forall a. Maybe SrcSpan -> FilePath -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
      FilePath
"modSummaryHsFile: missing .hs file for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
      Module -> FilePath
forall a. Outputable a => a -> FilePath
showPpr (ModSummary -> Module
ms_mod ModSummary
modSummary))
    (ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath) -> ModLocation -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
modSummary)

cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, Ms.BareSpec)]
cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, BareSpec)]
cachedBareSpecs SpecEnv
specEnv [Module]
mods = Module -> (ModName, BareSpec)
lookupBareSpec (Module -> (ModName, BareSpec))
-> [Module] -> [(ModName, BareSpec)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module]
mods
  where
    lookupBareSpec :: Module -> (ModName, BareSpec)
lookupBareSpec Module
m         = (ModName, BareSpec)
-> Maybe (ModName, BareSpec) -> (ModName, BareSpec)
forall a. a -> Maybe a -> a
fromMaybe (Module -> (ModName, BareSpec)
forall a a. Outputable a => a -> a
err Module
m) (SpecEnv -> Module -> Maybe (ModName, BareSpec)
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv SpecEnv
specEnv Module
m)
    err :: a -> a
err a
m                    = Maybe SrcSpan -> FilePath -> a
forall a. Maybe SrcSpan -> FilePath -> a
impossible Maybe SrcSpan
forall a. Maybe a
Nothing (FilePath
"lookupBareSpec: missing module " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Outputable a => a -> FilePath
showPpr a
m)

checkFilePragmas :: GhcMonadLike m => [Located String] -> m ()
checkFilePragmas :: [Located FilePath] -> m ()
checkFilePragmas = m () -> ([Error] -> m ()) -> [Error] -> m ()
forall b a. b -> ([a] -> b) -> [a] -> b
Misc.applyNonNull (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Error] -> m ()
forall a e. Exception e => e -> a
throw ([Error] -> m ())
-> ([Located FilePath] -> [Error]) -> [Located FilePath] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located FilePath -> Maybe Error) -> [Located FilePath] -> [Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located FilePath -> Maybe Error
err
  where
    err :: Located FilePath -> Maybe Error
err Located FilePath
pragma
      | FilePath -> Bool
check (Located FilePath -> FilePath
forall a. Located a -> a
val Located FilePath
pragma) = Error -> Maybe Error
forall a. a -> Maybe a
Just (SrcSpan -> Error
forall t. SrcSpan -> TError t
ErrFilePragma (SrcSpan -> Error) -> SrcSpan -> Error
forall a b. (a -> b) -> a -> b
$ Located FilePath -> SrcSpan
forall a. Loc a => a -> SrcSpan
fSrcSpan Located FilePath
pragma :: Error)
      | Bool
otherwise          = Maybe Error
forall a. Maybe a
Nothing
    check :: FilePath -> Bool
check FilePath
pragma           = (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
pragma) [FilePath]
forall a. IsString a => [a]
bad
    bad :: [a]
bad =
      [ a
"-i", a
"--idirs"
      , a
"-g", a
"--ghc-option"
      , a
"--c-files", a
"--cfiles"
      ]

--------------------------------------------------------------------------------
-- | Family instance information
--------------------------------------------------------------------------------
makeFamInstEnv :: [FamInst] -> ([GHC.TyCon], [(Symbol, DataCon)])
makeFamInstEnv :: [FamInst] -> ([TyCon], [(Symbol, DataCon)])
makeFamInstEnv [FamInst]
famInsts =
  let fiTcs :: [TyCon]
fiTcs = [ TyCon
tc            | FamInst { fi_flavor :: FamInst -> FamFlavor
fi_flavor = DataFamilyInst TyCon
tc } <- [FamInst]
famInsts ]
      fiDcs :: [(Symbol, DataCon)]
fiDcs = [ (DataCon -> Symbol
forall a. Symbolic a => a -> Symbol
symbol DataCon
d, DataCon
d) | TyCon
tc <- [TyCon]
fiTcs, DataCon
d <- TyCon -> [DataCon]
tyConDataCons TyCon
tc ]
  in ([TyCon]
fiTcs, [(Symbol, DataCon)]
fiDcs)

getFamInstances :: HscEnv -> IO [FamInst]
getFamInstances :: HscEnv -> IO [FamInst]
getFamInstances HscEnv
env = do
  (Messages
_, Just (FamInstEnv
pkg_fie, FamInstEnv
home_fie)) <- HscEnv -> TcRn FamInstEnvs -> IO (Messages, Maybe FamInstEnvs)
forall a. HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
env TcRn FamInstEnvs
tcGetFamInstEnvs
  [FamInst] -> IO [FamInst]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FamInst] -> IO [FamInst]) -> [FamInst] -> IO [FamInst]
forall a b. (a -> b) -> a -> b
$ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
 
--------------------------------------------------------------------------------
-- | Extract Specifications from GHC -------------------------------------------
--------------------------------------------------------------------------------
extractSpecComments :: ApiAnns -> [(SourcePos, String)]
extractSpecComments :: ApiAnns -> [(SourcePos, FilePath)]
extractSpecComments = (Located AnnotationComment -> Maybe (SourcePos, FilePath))
-> [Located AnnotationComment] -> [(SourcePos, FilePath)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located AnnotationComment -> Maybe (SourcePos, FilePath)
extractSpecComment
                    ([Located AnnotationComment] -> [(SourcePos, FilePath)])
-> (ApiAnns -> [Located AnnotationComment])
-> ApiAnns
-> [(SourcePos, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    ([[Located AnnotationComment]] -> [Located AnnotationComment])
-> (ApiAnns -> [[Located AnnotationComment]])
-> ApiAnns
-> [Located AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
M.elems
                    (Map SrcSpan [Located AnnotationComment]
 -> [[Located AnnotationComment]])
-> (ApiAnns -> Map SrcSpan [Located AnnotationComment])
-> ApiAnns
-> [[Located AnnotationComment]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd


-- | 'extractSpecComment' pulls out the specification part from a full comment
--   string, i.e. if the string is of the form:
--   1. '{-@ S @-}' then it returns the substring 'S',
--   2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and
--   3. Otherwise it is just treated as a plain comment so we return Nothing.
extractSpecComment :: GHC.Located AnnotationComment -> Maybe (SourcePos, String)

extractSpecComment :: Located AnnotationComment -> Maybe (SourcePos, FilePath)
extractSpecComment (GHC.L SrcSpan
sp (AnnBlockComment FilePath
text))
  | FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"{-@" FilePath
text Bool -> Bool -> Bool
&& FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
"@-}" FilePath
text          -- valid   specification
  = (SourcePos, FilePath) -> Maybe (SourcePos, FilePath)
forall a. a -> Maybe a
Just (SourcePos
offsetPos, Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
text Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
3 FilePath
text)
  | FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"{-@" FilePath
text                                   -- invalid specification
  = UserError -> Maybe (SourcePos, FilePath)
forall a. UserError -> a
uError (UserError -> Maybe (SourcePos, FilePath))
-> UserError -> Maybe (SourcePos, FilePath)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Doc -> UserError
forall t. SrcSpan -> Doc -> TError t
ErrParseAnn SrcSpan
sp Doc
"A valid specification must have a closing '@-}'."
  where
    offsetPos :: SourcePos
offsetPos = SourcePos -> Int -> SourcePos
incSourceColumn (SrcSpan -> SourcePos
srcSpanSourcePos SrcSpan
sp) Int
3
extractSpecComment Located AnnotationComment
_ = Maybe (SourcePos, FilePath)
forall a. Maybe a
Nothing

extractSpecQuotes :: TypecheckedModule -> [BPspec]
extractSpecQuotes :: TypecheckedModule -> [BPspec]
extractSpecQuotes = 
  (TypecheckedModule -> Module)
-> (TypecheckedModule -> [Annotation])
-> TypecheckedModule
-> [BPspec]
forall a. (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
extractSpecQuotes' (ModSummary -> Module
ms_mod (ModSummary -> Module)
-> (TypecheckedModule -> ModSummary) -> TypecheckedModule -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary (ParsedModule -> ModSummary)
-> (TypecheckedModule -> ParsedModule)
-> TypecheckedModule
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ParsedModule
tm_parsed_module) 
                     (TcGblEnv -> [Annotation]
tcg_anns (TcGblEnv -> [Annotation])
-> (TypecheckedModule -> TcGblEnv)
-> TypecheckedModule
-> [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TypecheckedModule -> (TcGblEnv, ModDetails))
-> TypecheckedModule
-> TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_)

extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
extractSpecQuotes' a -> Module
thisModule a -> [Annotation]
getAnns a
a = (AnnPayload -> Maybe BPspec) -> [AnnPayload] -> [BPspec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnnPayload -> Maybe BPspec
extractSpecQuote [AnnPayload]
anns
  where
    anns :: [AnnPayload]
anns = (Annotation -> AnnPayload) -> [Annotation] -> [AnnPayload]
forall a b. (a -> b) -> [a] -> [b]
map Annotation -> AnnPayload
ann_value ([Annotation] -> [AnnPayload]) -> [Annotation] -> [AnnPayload]
forall a b. (a -> b) -> a -> b
$
           (Annotation -> Bool) -> [Annotation] -> [Annotation]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnnTarget Name -> Bool
forall name. AnnTarget name -> Bool
isOurModTarget (AnnTarget Name -> Bool)
-> (Annotation -> AnnTarget Name) -> Annotation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> AnnTarget Name
ann_target) ([Annotation] -> [Annotation]) -> [Annotation] -> [Annotation]
forall a b. (a -> b) -> a -> b
$
           a -> [Annotation]
getAnns a
a

    isOurModTarget :: AnnTarget name -> Bool
isOurModTarget (ModuleTarget Module
mod1) = Module
mod1 Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Module
thisModule a
a
    isOurModTarget AnnTarget name
_ = Bool
False

extractSpecQuote :: AnnPayload -> Maybe BPspec
extractSpecQuote :: AnnPayload -> Maybe BPspec
extractSpecQuote AnnPayload
payload = 
  case ([Word8] -> LiquidQuote) -> AnnPayload -> Maybe LiquidQuote
forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
fromSerialized [Word8] -> LiquidQuote
forall a. Data a => [Word8] -> a
deserializeWithData AnnPayload
payload of
    Maybe LiquidQuote
Nothing -> Maybe BPspec
forall a. Maybe a
Nothing
    Just LiquidQuote
qt -> BPspec -> Maybe BPspec
forall a. a -> Maybe a
Just (BPspec -> Maybe BPspec) -> BPspec -> Maybe BPspec
forall a b. (a -> b) -> a -> b
$ BPspec -> BPspec
forall a. Data a => a -> a
refreshSymbols (BPspec -> BPspec) -> BPspec -> BPspec
forall a b. (a -> b) -> a -> b
$ LiquidQuote -> BPspec
liquidQuoteSpec LiquidQuote
qt

refreshSymbols :: Data a => a -> a
refreshSymbols :: a -> a
refreshSymbols = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Symbol -> Symbol) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Symbol -> Symbol
refreshSymbol)

refreshSymbol :: Symbol -> Symbol
refreshSymbol :: Symbol -> Symbol
refreshSymbol = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text -> Symbol) -> (Symbol -> Text) -> Symbol -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
symbolText

--------------------------------------------------------------------------------
-- | Finding & Parsing Files ---------------------------------------------------
--------------------------------------------------------------------------------

-- | Handle Spec Files ---------------------------------------------------------

findAndParseSpecFiles :: GhcMonadLike m
                      => Config
                      -> S.HashSet FilePath
                      -> ModSummary
                      -> [Module]
                      -> m [(ModName, Ms.BareSpec)]
findAndParseSpecFiles :: Config
-> HashSet FilePath
-> ModSummary
-> [Module]
-> m [(ModName, BareSpec)]
findAndParseSpecFiles Config
cfg HashSet FilePath
paths ModSummary
modSummary [Module]
reachable = do
  ModuleGraph
modGraph <- m ModuleGraph
forall (m :: * -> *). GhcMonadLike m => m ModuleGraph
GhcMonadLike.getModuleGraph
  [ModSummary]
impSumms <- (ModuleName -> m ModSummary) -> [ModuleName] -> m [ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> m ModSummary
forall (m :: * -> *). GhcMonadLike m => ModuleName -> m ModSummary
GhcMonadLike.getModSummary (Module -> ModuleName
moduleName (Module -> ModuleName) -> [Module] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module]
reachable)
  [Module]
imps''   <- [Module] -> [Module]
forall a. Eq a => [a] -> [a]
nub ([Module] -> [Module])
-> ([[Module]] -> [Module]) -> [[Module]] -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Module]] -> [Module]) -> m [[Module]] -> m [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModSummary -> m [Module]) -> [ModSummary] -> m [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModSummary -> m [Module]
forall (m :: * -> *). GhcMonadLike m => ModSummary -> m [Module]
modSummaryImports (ModSummary
modSummary ModSummary -> [ModSummary] -> [ModSummary]
forall a. a -> [a] -> [a]
: [ModSummary]
impSumms)
  [Module]
imps'    <- (Module -> m Bool) -> [Module] -> m [Module]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m Bool -> m Bool) -> (Module -> m Bool) -> Module -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> m Bool
forall (m :: * -> *). GhcMonadLike m => Module -> m Bool
isHomeModule) [Module]
imps''
  let imps :: [FilePath]
imps  = Module -> FilePath
m2s (Module -> FilePath) -> [Module] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module]
imps'
  [FilePath]
fs'      <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
Spec HashSet FilePath
paths [FilePath]
imps
  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps'': "  ++ show (m2s <$> imps''))
  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps' : "  ++ show (m2s <$> imps'))
  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps  : "  ++ show imps)
  -- liftIO  $ whenLoud  $ print ("moduleFiles-Paths : "  ++ show paths)
  -- liftIO  $ whenLoud  $ print ("moduleFiles-Specs : "  ++ show fs')
  [FilePath]
patSpec  <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> HashSet FilePath -> Bool -> IO [FilePath]
getPatSpec  ModuleGraph
modGraph HashSet FilePath
paths (Bool -> IO [FilePath]) -> Bool -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ Config -> Bool
forall t. HasConfig t => t -> Bool
totalityCheck Config
cfg
  [FilePath]
rlSpec   <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> HashSet FilePath -> Bool -> IO [FilePath]
getRealSpec ModuleGraph
modGraph HashSet FilePath
paths (Bool -> IO [FilePath]) -> Bool -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Config -> Bool
linear Config
cfg)
  let fs :: [FilePath]
fs    = [FilePath]
patSpec [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rlSpec [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
fs'
  IO [(ModName, BareSpec)] -> m [(ModName, BareSpec)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(ModName, BareSpec)] -> m [(ModName, BareSpec)])
-> IO [(ModName, BareSpec)] -> m [(ModName, BareSpec)]
forall a b. (a -> b) -> a -> b
$ ModuleGraph
-> HashSet FilePath
-> HashSet FilePath
-> [(ModName, BareSpec)]
-> [FilePath]
-> IO [(ModName, BareSpec)]
transParseSpecs ModuleGraph
modGraph HashSet FilePath
paths HashSet FilePath
forall a. Monoid a => a
mempty [(ModName, BareSpec)]
forall a. Monoid a => a
mempty [FilePath]
fs
  where
    m2s :: Module -> FilePath
m2s = ModuleName -> FilePath
moduleNameString (ModuleName -> FilePath)
-> (Module -> ModuleName) -> Module -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName

getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]
getPatSpec :: ModuleGraph -> HashSet FilePath -> Bool -> IO [FilePath]
getPatSpec ModuleGraph
modGraph HashSet FilePath
paths Bool
totalitycheck
 | Bool
totalitycheck = ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
Spec HashSet FilePath
paths [FilePath
forall p. IsString p => p
patErrorName]
 | Bool
otherwise     = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
 where
  patErrorName :: p
patErrorName   = p
"PatErr"

getRealSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]
getRealSpec :: ModuleGraph -> HashSet FilePath -> Bool -> IO [FilePath]
getRealSpec ModuleGraph
modGraph HashSet FilePath
paths Bool
freal
  | Bool
freal     = ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
Spec HashSet FilePath
paths [FilePath
forall p. IsString p => p
realSpecName]
  | Bool
otherwise = ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
Spec HashSet FilePath
paths [FilePath
forall p. IsString p => p
notRealSpecName]
  where
    realSpecName :: p
realSpecName    = p
"Real"
    notRealSpecName :: p
notRealSpecName = p
"NotReal"

transParseSpecs :: ModuleGraph
                -> S.HashSet FilePath
                -> S.HashSet FilePath 
                -> [(ModName, Ms.BareSpec)]
                -> [FilePath]
                -> IO [(ModName, Ms.BareSpec)]
transParseSpecs :: ModuleGraph
-> HashSet FilePath
-> HashSet FilePath
-> [(ModName, BareSpec)]
-> [FilePath]
-> IO [(ModName, BareSpec)]
transParseSpecs ModuleGraph
_ HashSet FilePath
_ HashSet FilePath
_ [(ModName, BareSpec)]
specs [] = [(ModName, BareSpec)] -> IO [(ModName, BareSpec)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ModName, BareSpec)]
specs
transParseSpecs ModuleGraph
modGraph HashSet FilePath
paths HashSet FilePath
seenFiles [(ModName, BareSpec)]
specs [FilePath]
newFiles = do
  -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)
  [(ModName, BareSpec)]
newSpecs      <- IO [(ModName, BareSpec)] -> IO [(ModName, BareSpec)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(ModName, BareSpec)] -> IO [(ModName, BareSpec)])
-> IO [(ModName, BareSpec)] -> IO [(ModName, BareSpec)]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO (ModName, BareSpec))
-> [FilePath] -> IO [(ModName, BareSpec)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (ModName, BareSpec)
parseSpecFile [FilePath]
newFiles
  [FilePath]
impFiles      <- ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
Spec HashSet FilePath
paths ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [(ModName, BareSpec)] -> [FilePath]
forall (t :: * -> *) a ty bndr.
Foldable t =>
t (a, Spec ty bndr) -> [FilePath]
specsImports [(ModName, BareSpec)]
newSpecs
  let seenFiles' :: HashSet FilePath
seenFiles' = HashSet FilePath
seenFiles HashSet FilePath -> HashSet FilePath -> HashSet FilePath
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.union` [FilePath] -> HashSet FilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [FilePath]
newFiles
  let specs' :: [(ModName, BareSpec)]
specs'     = [(ModName, BareSpec)]
specs [(ModName, BareSpec)]
-> [(ModName, BareSpec)] -> [(ModName, BareSpec)]
forall a. [a] -> [a] -> [a]
++ ((ModName, BareSpec) -> (ModName, BareSpec))
-> [(ModName, BareSpec)] -> [(ModName, BareSpec)]
forall a b. (a -> b) -> [a] -> [b]
map ((BareSpec -> BareSpec)
-> (ModName, BareSpec) -> (ModName, BareSpec)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second BareSpec -> BareSpec
noTerm) [(ModName, BareSpec)]
newSpecs
  let newFiles' :: [FilePath]
newFiles'  = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> HashSet FilePath -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet FilePath
seenFiles')) [FilePath]
impFiles
  ModuleGraph
-> HashSet FilePath
-> HashSet FilePath
-> [(ModName, BareSpec)]
-> [FilePath]
-> IO [(ModName, BareSpec)]
transParseSpecs ModuleGraph
modGraph HashSet FilePath
paths HashSet FilePath
seenFiles' [(ModName, BareSpec)]
specs' [FilePath]
newFiles'
  where
    specsImports :: t (a, Spec ty bndr) -> [FilePath]
specsImports t (a, Spec ty bndr)
ss = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ((a, Spec ty bndr) -> [FilePath])
-> t (a, Spec ty bndr) -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Symbol -> FilePath) -> [Symbol] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> FilePath
symbolString ([Symbol] -> [FilePath])
-> ((a, Spec ty bndr) -> [Symbol])
-> (a, Spec ty bndr)
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec ty bndr -> [Symbol]
forall ty bndr. Spec ty bndr -> [Symbol]
Ms.imports (Spec ty bndr -> [Symbol])
-> ((a, Spec ty bndr) -> Spec ty bndr)
-> (a, Spec ty bndr)
-> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Spec ty bndr) -> Spec ty bndr
forall a b. (a, b) -> b
snd) t (a, Spec ty bndr)
ss

noTerm :: Ms.BareSpec -> Ms.BareSpec
noTerm :: BareSpec -> BareSpec
noTerm BareSpec
spec = BareSpec
spec { decr :: [(LocSymbol, [Int])]
Ms.decr = [(LocSymbol, [Int])]
forall a. Monoid a => a
mempty, lazy :: HashSet LocSymbol
Ms.lazy = HashSet LocSymbol
forall a. Monoid a => a
mempty, termexprs :: [(LocSymbol, [Located Expr])]
Ms.termexprs = [(LocSymbol, [Located Expr])]
forall a. Monoid a => a
mempty }

parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)
parseSpecFile :: FilePath -> IO (ModName, BareSpec)
parseSpecFile FilePath
file = (Error -> IO (ModName, BareSpec))
-> ((ModName, BareSpec) -> IO (ModName, BareSpec))
-> Either Error (ModName, BareSpec)
-> IO (ModName, BareSpec)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> IO (ModName, BareSpec)
forall a e. Exception e => e -> a
throw (ModName, BareSpec) -> IO (ModName, BareSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (ModName, BareSpec) -> IO (ModName, BareSpec))
-> (FilePath -> Either Error (ModName, BareSpec))
-> FilePath
-> IO (ModName, BareSpec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Either Error (ModName, BareSpec)
specSpecificationP FilePath
file (FilePath -> IO (ModName, BareSpec))
-> IO FilePath -> IO (ModName, BareSpec)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
Misc.sayReadFile FilePath
file

-- Find Hquals Files -----------------------------------------------------------

-- _moduleHquals :: MGIModGuts
--              -> [FilePath]
--              -> FilePath
--              -> [String]
--              -> [FilePath]
--              -> Ghc [FilePath]
-- _moduleHquals mgi paths target imps incs = do
--   hqs   <- specIncludes Hquals paths incs
--   hqs'  <- moduleFiles Hquals paths (mgi_namestring mgi : imps)
--   hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]
--   return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'

-- Find Files for Modules ------------------------------------------------------

moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]
moduleFiles :: ModuleGraph
-> Ext -> HashSet FilePath -> [FilePath] -> IO [FilePath]
moduleFiles ModuleGraph
modGraph Ext
ext HashSet FilePath
paths [FilePath]
names = [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModuleGraph
-> Ext -> HashSet FilePath -> FilePath -> IO (Maybe FilePath)
moduleFile ModuleGraph
modGraph Ext
ext HashSet FilePath
paths) [FilePath]
names

moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)
moduleFile :: ModuleGraph
-> Ext -> HashSet FilePath -> FilePath -> IO (Maybe FilePath)
moduleFile ModuleGraph
modGraph Ext
ext (HashSet FilePath -> [FilePath]
forall a. HashSet a -> [a]
S.toList -> [FilePath]
paths) FilePath
name
  | Ext
ext Ext -> [Ext] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ext
Hs, Ext
LHs] = do
    let graph :: [ModSummary]
graph = ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
modGraph
    case (ModSummary -> Bool) -> [ModSummary] -> Maybe ModSummary
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ModSummary
m -> Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
m) Bool -> Bool -> Bool
&&
                     FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName -> FilePath
moduleNameString (ModSummary -> ModuleName
ms_mod_name ModSummary
m)) [ModSummary]
graph of
      Maybe ModSummary
Nothing -> FilePath -> [FilePath] -> IO (Maybe FilePath)
getFileInDirs (FilePath -> Ext -> FilePath
extModuleName FilePath
name Ext
ext) [FilePath]
paths
      Just ModSummary
ms -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
  | Bool
otherwise = FilePath -> [FilePath] -> IO (Maybe FilePath)
getFileInDirs (FilePath -> Ext -> FilePath
extModuleName FilePath
name Ext
ext) [FilePath]
paths

--------------------------------------------------------------------------------
-- Assemble Information for Spec Extraction ------------------------------------
--------------------------------------------------------------------------------

makeMGIModGuts :: ModGuts -> MGIModGuts
makeMGIModGuts :: ModGuts -> MGIModGuts
makeMGIModGuts ModGuts
modGuts = Maybe [ClsInst] -> ModGuts -> MGIModGuts
miModGuts Maybe [ClsInst]
deriv ModGuts
modGuts
  where
    deriv :: Maybe [ClsInst]
deriv   = [ClsInst] -> Maybe [ClsInst]
forall a. a -> Maybe a
Just ([ClsInst] -> Maybe [ClsInst]) -> [ClsInst] -> Maybe [ClsInst]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModGuts -> InstEnv
mg_inst_env ModGuts
modGuts

makeLogicMap :: IO LogicMap
makeLogicMap :: IO LogicMap
makeLogicMap = do
  FilePath
lg    <- IO FilePath
Misc.getCoreToLogicPath
  FilePath
lspec <- FilePath -> IO FilePath
Misc.sayReadFile FilePath
lg
  case FilePath -> FilePath -> Either Error LogicMap
parseSymbolToLogic FilePath
lg FilePath
lspec of 
    Left Error
e   -> Error -> IO LogicMap
forall a e. Exception e => e -> a
throw Error
e 
    Right LogicMap
lm -> LogicMap -> IO LogicMap
forall (m :: * -> *) a. Monad m => a -> m a
return (LogicMap
lm LogicMap -> LogicMap -> LogicMap
forall a. Semigroup a => a -> a -> a
<> LogicMap
listLMap)

listLMap :: LogicMap -- TODO-REBARE: move to wiredIn
listLMap :: LogicMap
listLMap  = [(LocSymbol, [Symbol], Expr)] -> LogicMap
toLogicMap [ (Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc Symbol
nilName , []     , Expr
hNil)
                       , (Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc Symbol
consName, [Symbol
forall p. IsString p => p
x, Symbol
forall p. IsString p => p
xs], [Expr] -> Expr
hCons (Symbol -> Expr
EVar (Symbol -> Expr) -> [Symbol] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol
forall p. IsString p => p
x, Symbol
forall p. IsString p => p
xs])) ]
  where
    x :: p
x     = p
"x"
    xs :: p
xs    = p
"xs"
    hNil :: Expr
hNil  = LocSymbol -> [Expr] -> Expr
mkEApp (DataCon -> LocSymbol
forall a. Symbolic a => a -> LocSymbol
dcSym DataCon
Ghc.nilDataCon ) []
    hCons :: [Expr] -> Expr
hCons = LocSymbol -> [Expr] -> Expr
mkEApp (DataCon -> LocSymbol
forall a. Symbolic a => a -> LocSymbol
dcSym DataCon
Ghc.consDataCon)
    dcSym :: a -> LocSymbol
dcSym = Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc (Symbol -> LocSymbol) -> (a -> Symbol) -> a -> LocSymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleUnique (Symbol -> Symbol) -> (a -> Symbol) -> a -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Symbol
forall a. Symbolic a => a -> Symbol
symbol



--------------------------------------------------------------------------------
-- | Pretty Printing -----------------------------------------------------------
--------------------------------------------------------------------------------

instance PPrint TargetSpec where
  pprintTidy :: Tidy -> TargetSpec -> Doc
pprintTidy Tidy
k TargetSpec
spec = [Doc] -> Doc
vcat
    [ Doc
"******* Target Variables ********************"
    , Tidy -> [Id] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k ([Id] -> Doc) -> [Id] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSpecVars -> [Id]
gsTgtVars (TargetSpec -> GhcSpecVars
gsVars TargetSpec
spec)
    , Doc
"******* Type Signatures *********************"
    , Tidy -> [(Id, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(Id, LocSpecType)]
gsTySigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* Assumed Type Signatures *************"
    , Tidy -> [(Id, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(Id, LocSpecType)]
gsAsmSigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* DataCon Specifications (Measure) ****"
    , Tidy -> [(Id, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecData -> [(Id, LocSpecType)]
gsCtors (TargetSpec -> GhcSpecData
gsData TargetSpec
spec))
    , Doc
"******* Measure Specifications **************"
    , Tidy -> [(Symbol, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecData -> [(Symbol, LocSpecType)]
gsMeas (TargetSpec -> GhcSpecData
gsData TargetSpec
spec))       ]

instance PPrint TargetInfo where
  pprintTidy :: Tidy -> TargetInfo -> Doc
pprintTidy Tidy
k TargetInfo
info = [Doc] -> Doc
vcat
    [ -- "*************** Imports *********************"
      -- , intersperse comma $ text <$> imports info
      -- , "*************** Includes ********************"
      -- , intersperse comma $ text <$> includes info
      Doc
"*************** Imported Variables **********"
    , [Id] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([Id] -> Doc) -> [Id] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [Id]
_giImpVars (Optic' An_Iso NoIx GhcSrc TargetSrc -> TargetSrc -> GhcSrc
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso NoIx GhcSrc TargetSrc
targetSrcIso (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info)
    , Doc
"*************** Defined Variables ***********"
    , [Id] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([Id] -> Doc) -> [Id] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [Id]
_giDefVars (Optic' An_Iso NoIx GhcSrc TargetSrc -> TargetSrc -> GhcSrc
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso NoIx GhcSrc TargetSrc
targetSrcIso (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info)
    , Doc
"*************** Specification ***************"
    , Tidy -> TargetSpec -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k (TargetSpec -> Doc) -> TargetSpec -> Doc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSpec
giSpec TargetInfo
info
    , Doc
"*************** Core Bindings ***************"
    , CoreProgram -> Doc
pprintCBs (CoreProgram -> Doc) -> CoreProgram -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> CoreProgram
_giCbs (Optic' An_Iso NoIx GhcSrc TargetSrc -> TargetSrc -> GhcSrc
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso NoIx GhcSrc TargetSrc
targetSrcIso (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info) ]

-- RJ: the silly guards below are to silence the unused-var checker
pprintCBs :: [CoreBind] -> Doc
pprintCBs :: CoreProgram -> Doc
pprintCBs
  | Bool
otherwise = CoreProgram -> Doc
pprintCBsTidy
  | Bool
otherwise = CoreProgram -> Doc
pprintCBsVerbose
  where
    pprintCBsTidy :: CoreProgram -> Doc
pprintCBsTidy    = CoreProgram -> Doc
forall a. Outputable a => a -> Doc
pprDoc (CoreProgram -> Doc)
-> (CoreProgram -> CoreProgram) -> CoreProgram -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreProgram -> CoreProgram
tidyCBs
    pprintCBsVerbose :: CoreProgram -> Doc
pprintCBsVerbose = FilePath -> Doc
text (FilePath -> Doc)
-> (CoreProgram -> FilePath) -> CoreProgram -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> MsgDoc -> FilePath
O.showSDocDebug DynFlags
unsafeGlobalDynFlags (MsgDoc -> FilePath)
-> (CoreProgram -> MsgDoc) -> CoreProgram -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreProgram -> MsgDoc
forall a. Outputable a => a -> MsgDoc
O.ppr (CoreProgram -> MsgDoc)
-> (CoreProgram -> CoreProgram) -> CoreProgram -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreProgram -> CoreProgram
tidyCBs

instance Show TargetInfo where
  show :: TargetInfo -> FilePath
show = TargetInfo -> FilePath
forall a. PPrint a => a -> FilePath
showpp

instance PPrint TargetVars where
  pprintTidy :: Tidy -> TargetVars -> Doc
pprintTidy Tidy
_ TargetVars
AllVars   = FilePath -> Doc
text FilePath
"All Variables"
  pprintTidy Tidy
k (Only [Id]
vs) = FilePath -> Doc
text FilePath
"Only Variables: " Doc -> Doc -> Doc
<+> Tidy -> [Id] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k [Id]
vs

------------------------------------------------------------------------
-- Dealing with Errors ---------------------------------------------------
------------------------------------------------------------------------

instance Result SourceError where
  result :: SourceError -> FixResult UserError
result = ([UserError] -> FilePath -> FixResult UserError
forall a. [a] -> FilePath -> FixResult a
`Crash` FilePath
"Invalid Source") ([UserError] -> FixResult UserError)
-> (SourceError -> [UserError])
-> SourceError
-> FixResult UserError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> SourceError -> [UserError]
forall t. FilePath -> SourceError -> [TError t]
sourceErrors FilePath
""